1 /* 2 * v m . c 3 * Forth Inspired Command Language - virtual machine methods 4 * Author: John Sadler (john_sadler@alum.mit.edu) 5 * Created: 19 July 1997 6 * $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $ 7 */ 8 /* 9 * This file implements the virtual machine of Ficl. Each virtual 10 * machine retains the state of an interpreter. A virtual machine 11 * owns a pair of stacks for parameters and return addresses, as 12 * well as a pile of state variables and the two dedicated registers 13 * of the interpreter. 14 */ 15 /* 16 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 17 * All rights reserved. 18 * 19 * Get the latest Ficl release at http://ficl.sourceforge.net 20 * 21 * I am interested in hearing from anyone who uses Ficl. If you have 22 * a problem, a success story, a defect, an enhancement request, or 23 * if you would like to contribute to the Ficl release, please 24 * contact me by email at the address above. 25 * 26 * L I C E N S E and D I S C L A I M E R 27 * 28 * Redistribution and use in source and binary forms, with or without 29 * modification, are permitted provided that the following conditions 30 * are met: 31 * 1. Redistributions of source code must retain the above copyright 32 * notice, this list of conditions and the following disclaimer. 33 * 2. Redistributions in binary form must reproduce the above copyright 34 * notice, this list of conditions and the following disclaimer in the 35 * documentation and/or other materials provided with the distribution. 36 * 37 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 38 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 39 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 40 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 41 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 42 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 43 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 44 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 45 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 46 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 47 * SUCH DAMAGE. 48 */ 49 50 #include "ficl.h" 51 52 #if FICL_ROBUST >= 2 53 #define FICL_VM_CHECK(vm) \ 54 FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord) 55 #else 56 #define FICL_VM_CHECK(vm) 57 #endif 58 59 /* 60 * v m B r a n c h R e l a t i v e 61 */ 62 void 63 ficlVmBranchRelative(ficlVm *vm, int offset) 64 { 65 vm->ip += offset; 66 } 67 68 /* 69 * v m C r e a t e 70 * Creates a virtual machine either from scratch (if vm is NULL on entry) 71 * or by resizing and reinitializing an existing VM to the specified stack 72 * sizes. 73 */ 74 ficlVm * 75 ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack) 76 { 77 if (vm == NULL) { 78 vm = (ficlVm *)ficlMalloc(sizeof (ficlVm)); 79 FICL_ASSERT(NULL, vm); 80 memset(vm, 0, sizeof (ficlVm)); 81 } 82 83 if (vm->dataStack) 84 ficlStackDestroy(vm->dataStack); 85 vm->dataStack = ficlStackCreate(vm, "data", nPStack); 86 87 if (vm->returnStack) 88 ficlStackDestroy(vm->returnStack); 89 vm->returnStack = ficlStackCreate(vm, "return", nRStack); 90 91 #if FICL_WANT_FLOAT 92 if (vm->floatStack) 93 ficlStackDestroy(vm->floatStack); 94 vm->floatStack = ficlStackCreate(vm, "float", nPStack); 95 #endif 96 97 ficlVmReset(vm); 98 return (vm); 99 } 100 101 /* 102 * v m D e l e t e 103 * Free all memory allocated to the specified VM and its subordinate 104 * structures. 105 */ 106 void 107 ficlVmDestroy(ficlVm *vm) 108 { 109 if (vm) { 110 ficlFree(vm->dataStack); 111 ficlFree(vm->returnStack); 112 #if FICL_WANT_FLOAT 113 ficlFree(vm->floatStack); 114 #endif 115 ficlFree(vm); 116 } 117 } 118 119 /* 120 * v m E x e c u t e 121 * Sets up the specified word to be run by the inner interpreter. 122 * Executes the word's code part immediately, but in the case of 123 * colon definition, the definition itself needs the inner interpreter 124 * to complete. This does not happen until control reaches ficlExec 125 */ 126 void 127 ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord) 128 { 129 ficlVmInnerLoop(vm, pWord); 130 } 131 132 static void 133 ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip) 134 { 135 ficlIp destination; 136 switch ((ficlInstruction)(*ip)) { 137 case ficlInstructionBranchParenWithCheck: 138 *ip = (ficlWord *)ficlInstructionBranchParen; 139 goto RUNTIME_FIXUP; 140 141 case ficlInstructionBranch0ParenWithCheck: 142 *ip = (ficlWord *)ficlInstructionBranch0Paren; 143 RUNTIME_FIXUP: 144 ip++; 145 destination = ip + *(ficlInteger *)ip; 146 switch ((ficlInstruction)*destination) { 147 case ficlInstructionBranchParenWithCheck: 148 /* preoptimize where we're jumping to */ 149 ficlVmOptimizeJumpToJump(vm, destination); 150 /* FALLTHROUGH */ 151 case ficlInstructionBranchParen: 152 destination++; 153 destination += *(ficlInteger *)destination; 154 *ip = (ficlWord *)(destination - ip); 155 break; 156 } 157 } 158 } 159 160 /* 161 * v m I n n e r L o o p 162 * the mysterious inner interpreter... 163 * This loop is the address interpreter that makes colon definitions 164 * work. Upon entry, it assumes that the IP points to an entry in 165 * a definition (the body of a colon word). It runs one word at a time 166 * until something does vmThrow. The catcher for this is expected to exist 167 * in the calling code. 168 * vmThrow gets you out of this loop with a longjmp() 169 */ 170 171 #if FICL_ROBUST <= 1 172 /* turn off stack checking for primitives */ 173 #define _CHECK_STACK(stack, top, pop, push) 174 #else 175 176 #define _CHECK_STACK(stack, top, pop, push) \ 177 ficlStackCheckNospill(stack, top, pop, push) 178 179 FICL_PLATFORM_INLINE void 180 ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells, 181 int pushCells) 182 { 183 /* 184 * Why save and restore stack->top? 185 * So the simple act of stack checking doesn't force a "register" spill, 186 * which might mask bugs (places where we needed to spill but didn't). 187 * --lch 188 */ 189 ficlCell *oldTop = stack->top; 190 stack->top = top; 191 ficlStackCheck(stack, popCells, pushCells); 192 stack->top = oldTop; 193 } 194 195 #endif /* FICL_ROBUST <= 1 */ 196 197 #define CHECK_STACK(pop, push) \ 198 _CHECK_STACK(vm->dataStack, dataTop, pop, push) 199 #define CHECK_FLOAT_STACK(pop, push) \ 200 _CHECK_STACK(vm->floatStack, floatTop, pop, push) 201 #define CHECK_RETURN_STACK(pop, push) \ 202 _CHECK_STACK(vm->returnStack, returnTop, pop, push) 203 204 #if FICL_WANT_FLOAT 205 #define FLOAT_LOCAL_VARIABLE_SPILL \ 206 vm->floatStack->top = floatTop; 207 #define FLOAT_LOCAL_VARIABLE_REFILL \ 208 floatTop = vm->floatStack->top; 209 #else 210 #define FLOAT_LOCAL_VARIABLE_SPILL 211 #define FLOAT_LOCAL_VARIABLE_REFILL 212 #endif /* FICL_WANT_FLOAT */ 213 214 #if FICL_WANT_LOCALS 215 #define LOCALS_LOCAL_VARIABLE_SPILL \ 216 vm->returnStack->frame = frame; 217 #define LOCALS_LOCAL_VARIABLE_REFILL \ 218 frame = vm->returnStack->frame; 219 #else 220 #define LOCALS_LOCAL_VARIABLE_SPILL 221 #define LOCALS_LOCAL_VARIABLE_REFILL 222 #endif /* FICL_WANT_FLOAT */ 223 224 #define LOCAL_VARIABLE_SPILL \ 225 vm->ip = (ficlIp)ip; \ 226 vm->dataStack->top = dataTop; \ 227 vm->returnStack->top = returnTop; \ 228 FLOAT_LOCAL_VARIABLE_SPILL \ 229 LOCALS_LOCAL_VARIABLE_SPILL 230 231 #define LOCAL_VARIABLE_REFILL \ 232 ip = (ficlInstruction *)vm->ip; \ 233 dataTop = vm->dataStack->top; \ 234 returnTop = vm->returnStack->top; \ 235 FLOAT_LOCAL_VARIABLE_REFILL \ 236 LOCALS_LOCAL_VARIABLE_REFILL 237 238 void 239 ficlVmInnerLoop(ficlVm *vm, ficlWord *fw) 240 { 241 register ficlInstruction *ip; 242 register ficlCell *dataTop; 243 register ficlCell *returnTop; 244 #if FICL_WANT_FLOAT 245 register ficlCell *floatTop; 246 ficlFloat f; 247 #endif /* FICL_WANT_FLOAT */ 248 #if FICL_WANT_LOCALS 249 register ficlCell *frame; 250 #endif /* FICL_WANT_LOCALS */ 251 jmp_buf *oldExceptionHandler; 252 jmp_buf exceptionHandler; 253 int except; 254 int once; 255 int count; 256 ficlInstruction instruction; 257 ficlInteger i; 258 ficlUnsigned u; 259 ficlCell c; 260 ficlCountedString *s; 261 ficlCell *cell; 262 char *cp; 263 264 once = (fw != NULL); 265 if (once) 266 count = 1; 267 268 oldExceptionHandler = vm->exceptionHandler; 269 /* This has to come before the setjmp! */ 270 vm->exceptionHandler = &exceptionHandler; 271 except = setjmp(exceptionHandler); 272 273 LOCAL_VARIABLE_REFILL; 274 275 if (except) { 276 LOCAL_VARIABLE_SPILL; 277 vm->exceptionHandler = oldExceptionHandler; 278 ficlVmThrow(vm, except); 279 } 280 281 for (;;) { 282 if (once) { 283 if (!count--) 284 break; 285 instruction = (ficlInstruction)((void *)fw); 286 } else { 287 instruction = *ip++; 288 fw = (ficlWord *)instruction; 289 } 290 291 AGAIN: 292 switch (instruction) { 293 case ficlInstructionInvalid: 294 ficlVmThrowError(vm, 295 "Error: NULL instruction executed!"); 296 return; 297 298 case ficlInstruction1: 299 case ficlInstruction2: 300 case ficlInstruction3: 301 case ficlInstruction4: 302 case ficlInstruction5: 303 case ficlInstruction6: 304 case ficlInstruction7: 305 case ficlInstruction8: 306 case ficlInstruction9: 307 case ficlInstruction10: 308 case ficlInstruction11: 309 case ficlInstruction12: 310 case ficlInstruction13: 311 case ficlInstruction14: 312 case ficlInstruction15: 313 case ficlInstruction16: 314 CHECK_STACK(0, 1); 315 (++dataTop)->i = instruction; 316 continue; 317 318 case ficlInstruction0: 319 case ficlInstructionNeg1: 320 case ficlInstructionNeg2: 321 case ficlInstructionNeg3: 322 case ficlInstructionNeg4: 323 case ficlInstructionNeg5: 324 case ficlInstructionNeg6: 325 case ficlInstructionNeg7: 326 case ficlInstructionNeg8: 327 case ficlInstructionNeg9: 328 case ficlInstructionNeg10: 329 case ficlInstructionNeg11: 330 case ficlInstructionNeg12: 331 case ficlInstructionNeg13: 332 case ficlInstructionNeg14: 333 case ficlInstructionNeg15: 334 case ficlInstructionNeg16: 335 CHECK_STACK(0, 1); 336 (++dataTop)->i = ficlInstruction0 - instruction; 337 continue; 338 339 /* 340 * stringlit: Fetch the count from the dictionary, then push 341 * the address and count on the stack. Finally, update ip to 342 * point to the first aligned address after the string text. 343 */ 344 case ficlInstructionStringLiteralParen: { 345 ficlUnsigned8 length; 346 CHECK_STACK(0, 2); 347 348 s = (ficlCountedString *)(ip); 349 length = s->length; 350 cp = s->text; 351 (++dataTop)->p = cp; 352 (++dataTop)->i = length; 353 354 cp += length + 1; 355 cp = ficlAlignPointer(cp); 356 ip = (void *)cp; 357 continue; 358 } 359 360 case ficlInstructionCStringLiteralParen: 361 CHECK_STACK(0, 1); 362 363 s = (ficlCountedString *)(ip); 364 cp = s->text + s->length + 1; 365 cp = ficlAlignPointer(cp); 366 ip = (void *)cp; 367 (++dataTop)->p = s; 368 continue; 369 370 #if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE 371 #if FICL_WANT_FLOAT 372 FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC: 373 *++floatTop = cell[1]; 374 /* intentional fall-through */ 375 FLOAT_PUSH_CELL_POINTER_MINIPROC: 376 *++floatTop = cell[0]; 377 continue; 378 379 FLOAT_POP_CELL_POINTER_MINIPROC: 380 cell[0] = *floatTop--; 381 continue; 382 383 FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC: 384 cell[0] = *floatTop--; 385 cell[1] = *floatTop--; 386 continue; 387 388 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \ 389 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC 390 #define FLOAT_PUSH_CELL_POINTER(cp) \ 391 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC 392 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \ 393 cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC 394 #define FLOAT_POP_CELL_POINTER(cp) \ 395 cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC 396 #endif /* FICL_WANT_FLOAT */ 397 398 /* 399 * Think of these as little mini-procedures. 400 * --lch 401 */ 402 PUSH_CELL_POINTER_DOUBLE_MINIPROC: 403 *++dataTop = cell[1]; 404 /* intentional fall-through */ 405 PUSH_CELL_POINTER_MINIPROC: 406 *++dataTop = cell[0]; 407 continue; 408 409 POP_CELL_POINTER_MINIPROC: 410 cell[0] = *dataTop--; 411 continue; 412 POP_CELL_POINTER_DOUBLE_MINIPROC: 413 cell[0] = *dataTop--; 414 cell[1] = *dataTop--; 415 continue; 416 417 #define PUSH_CELL_POINTER_DOUBLE(cp) \ 418 cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC 419 #define PUSH_CELL_POINTER(cp) \ 420 cell = (cp); goto PUSH_CELL_POINTER_MINIPROC 421 #define POP_CELL_POINTER_DOUBLE(cp) \ 422 cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC 423 #define POP_CELL_POINTER(cp) \ 424 cell = (cp); goto POP_CELL_POINTER_MINIPROC 425 426 BRANCH_MINIPROC: 427 ip += *(ficlInteger *)ip; 428 continue; 429 430 #define BRANCH() goto BRANCH_MINIPROC 431 432 EXIT_FUNCTION_MINIPROC: 433 ip = (ficlInstruction *)((returnTop--)->p); 434 continue; 435 436 #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC 437 438 #else /* FICL_WANT_SIZE */ 439 440 #if FICL_WANT_FLOAT 441 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \ 442 cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue 443 #define FLOAT_PUSH_CELL_POINTER(cp) \ 444 cell = (cp); *++floatTop = *cell; continue 445 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \ 446 cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue 447 #define FLOAT_POP_CELL_POINTER(cp) \ 448 cell = (cp); *cell = *floatTop--; continue 449 #endif /* FICL_WANT_FLOAT */ 450 451 #define PUSH_CELL_POINTER_DOUBLE(cp) \ 452 cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue 453 #define PUSH_CELL_POINTER(cp) \ 454 cell = (cp); *++dataTop = *cell; continue 455 #define POP_CELL_POINTER_DOUBLE(cp) \ 456 cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue 457 #define POP_CELL_POINTER(cp) \ 458 cell = (cp); *cell = *dataTop--; continue 459 460 #define BRANCH() ip += *(ficlInteger *)ip; continue 461 #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue 462 463 #endif /* FICL_WANT_SIZE */ 464 465 466 /* 467 * This is the runtime for (literal). It assumes that it is 468 * part of a colon definition, and that the next ficlCell 469 * contains a value to be pushed on the parameter stack at 470 * runtime. This code is compiled by "literal". 471 */ 472 473 case ficlInstructionLiteralParen: 474 CHECK_STACK(0, 1); 475 (++dataTop)->i = *ip++; 476 continue; 477 478 case ficlInstruction2LiteralParen: 479 CHECK_STACK(0, 2); 480 (++dataTop)->i = ip[1]; 481 (++dataTop)->i = ip[0]; 482 ip += 2; 483 continue; 484 485 #if FICL_WANT_LOCALS 486 /* 487 * Link a frame on the return stack, reserving nCells of space 488 * for locals - the value of nCells is the next ficlCell in 489 * the instruction stream. 490 * 1) Push frame onto returnTop 491 * 2) frame = returnTop 492 * 3) returnTop += nCells 493 */ 494 case ficlInstructionLinkParen: { 495 ficlInteger nCells = *ip++; 496 (++returnTop)->p = frame; 497 frame = returnTop + 1; 498 returnTop += nCells; 499 continue; 500 } 501 502 /* 503 * Unink a stack frame previously created by stackLink 504 * 1) dataTop = frame 505 * 2) frame = pop() 506 */ 507 case ficlInstructionUnlinkParen: 508 returnTop = frame - 1; 509 frame = (returnTop--)->p; 510 continue; 511 512 /* 513 * Immediate - cfa of a local while compiling - when executed, 514 * compiles code to fetch the value of a local given the 515 * local's index in the word's pfa 516 */ 517 #if FICL_WANT_FLOAT 518 case ficlInstructionGetF2LocalParen: 519 FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++); 520 521 case ficlInstructionGetFLocalParen: 522 FLOAT_PUSH_CELL_POINTER(frame + *ip++); 523 524 case ficlInstructionToF2LocalParen: 525 FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++); 526 527 case ficlInstructionToFLocalParen: 528 FLOAT_POP_CELL_POINTER(frame + *ip++); 529 #endif /* FICL_WANT_FLOAT */ 530 531 case ficlInstructionGet2LocalParen: 532 PUSH_CELL_POINTER_DOUBLE(frame + *ip++); 533 534 case ficlInstructionGetLocalParen: 535 PUSH_CELL_POINTER(frame + *ip++); 536 537 /* 538 * Immediate - cfa of a local while compiling - when executed, 539 * compiles code to store the value of a local given the 540 * local's index in the word's pfa 541 */ 542 543 case ficlInstructionTo2LocalParen: 544 POP_CELL_POINTER_DOUBLE(frame + *ip++); 545 546 case ficlInstructionToLocalParen: 547 POP_CELL_POINTER(frame + *ip++); 548 549 /* 550 * Silly little minor optimizations. 551 * --lch 552 */ 553 case ficlInstructionGetLocal0: 554 PUSH_CELL_POINTER(frame); 555 556 case ficlInstructionGetLocal1: 557 PUSH_CELL_POINTER(frame + 1); 558 559 case ficlInstructionGet2Local0: 560 PUSH_CELL_POINTER_DOUBLE(frame); 561 562 case ficlInstructionToLocal0: 563 POP_CELL_POINTER(frame); 564 565 case ficlInstructionToLocal1: 566 POP_CELL_POINTER(frame + 1); 567 568 case ficlInstructionTo2Local0: 569 POP_CELL_POINTER_DOUBLE(frame); 570 571 #endif /* FICL_WANT_LOCALS */ 572 573 case ficlInstructionPlus: 574 CHECK_STACK(2, 1); 575 i = (dataTop--)->i; 576 dataTop->i += i; 577 continue; 578 579 case ficlInstructionMinus: 580 CHECK_STACK(2, 1); 581 i = (dataTop--)->i; 582 dataTop->i -= i; 583 continue; 584 585 case ficlInstruction1Plus: 586 CHECK_STACK(1, 1); 587 dataTop->i++; 588 continue; 589 590 case ficlInstruction1Minus: 591 CHECK_STACK(1, 1); 592 dataTop->i--; 593 continue; 594 595 case ficlInstruction2Plus: 596 CHECK_STACK(1, 1); 597 dataTop->i += 2; 598 continue; 599 600 case ficlInstruction2Minus: 601 CHECK_STACK(1, 1); 602 dataTop->i -= 2; 603 continue; 604 605 case ficlInstructionDup: { 606 ficlInteger i = dataTop->i; 607 CHECK_STACK(0, 1); 608 (++dataTop)->i = i; 609 continue; 610 } 611 612 case ficlInstructionQuestionDup: 613 CHECK_STACK(1, 2); 614 615 if (dataTop->i != 0) { 616 dataTop[1] = dataTop[0]; 617 dataTop++; 618 } 619 620 continue; 621 622 case ficlInstructionSwap: { 623 ficlCell swap; 624 CHECK_STACK(2, 2); 625 swap = dataTop[0]; 626 dataTop[0] = dataTop[-1]; 627 dataTop[-1] = swap; 628 } 629 continue; 630 631 case ficlInstructionDrop: 632 CHECK_STACK(1, 0); 633 dataTop--; 634 continue; 635 636 case ficlInstruction2Drop: 637 CHECK_STACK(2, 0); 638 dataTop -= 2; 639 continue; 640 641 case ficlInstruction2Dup: 642 CHECK_STACK(2, 4); 643 dataTop[1] = dataTop[-1]; 644 dataTop[2] = *dataTop; 645 dataTop += 2; 646 continue; 647 648 case ficlInstructionOver: 649 CHECK_STACK(2, 3); 650 dataTop[1] = dataTop[-1]; 651 dataTop++; 652 continue; 653 654 case ficlInstruction2Over: 655 CHECK_STACK(4, 6); 656 dataTop[1] = dataTop[-3]; 657 dataTop[2] = dataTop[-2]; 658 dataTop += 2; 659 continue; 660 661 case ficlInstructionPick: 662 CHECK_STACK(1, 0); 663 i = dataTop->i; 664 if (i < 0) 665 continue; 666 CHECK_STACK(i + 2, i + 3); 667 *dataTop = dataTop[-i - 1]; 668 continue; 669 670 /* 671 * Do stack rot. 672 * rot ( 1 2 3 -- 2 3 1 ) 673 */ 674 case ficlInstructionRot: 675 i = 2; 676 goto ROLL; 677 678 /* 679 * Do stack roll. 680 * roll ( n -- ) 681 */ 682 case ficlInstructionRoll: 683 CHECK_STACK(1, 0); 684 i = (dataTop--)->i; 685 686 if (i < 1) 687 continue; 688 689 ROLL: 690 CHECK_STACK(i+1, i+2); 691 c = dataTop[-i]; 692 memmove(dataTop - i, dataTop - (i - 1), 693 i * sizeof (ficlCell)); 694 *dataTop = c; 695 continue; 696 697 /* 698 * Do stack -rot. 699 * -rot ( 1 2 3 -- 3 1 2 ) 700 */ 701 case ficlInstructionMinusRot: 702 i = 2; 703 goto MINUSROLL; 704 705 /* 706 * Do stack -roll. 707 * -roll ( n -- ) 708 */ 709 case ficlInstructionMinusRoll: 710 CHECK_STACK(1, 0); 711 i = (dataTop--)->i; 712 713 if (i < 1) 714 continue; 715 716 MINUSROLL: 717 CHECK_STACK(i+1, i+2); 718 c = *dataTop; 719 memmove(dataTop - (i - 1), dataTop - i, 720 i * sizeof (ficlCell)); 721 dataTop[-i] = c; 722 723 continue; 724 725 /* 726 * Do stack 2swap 727 * 2swap ( 1 2 3 4 -- 3 4 1 2 ) 728 */ 729 case ficlInstruction2Swap: { 730 ficlCell c2; 731 CHECK_STACK(4, 4); 732 733 c = *dataTop; 734 c2 = dataTop[-1]; 735 736 *dataTop = dataTop[-2]; 737 dataTop[-1] = dataTop[-3]; 738 739 dataTop[-2] = c; 740 dataTop[-3] = c2; 741 continue; 742 } 743 744 case ficlInstructionPlusStore: { 745 ficlCell *cell; 746 CHECK_STACK(2, 0); 747 cell = (ficlCell *)(dataTop--)->p; 748 cell->i += (dataTop--)->i; 749 continue; 750 } 751 752 case ficlInstructionQuadFetch: { 753 ficlUnsigned32 *integer32; 754 CHECK_STACK(1, 1); 755 integer32 = (ficlUnsigned32 *)dataTop->i; 756 dataTop->u = (ficlUnsigned)*integer32; 757 continue; 758 } 759 760 case ficlInstructionQuadStore: { 761 ficlUnsigned32 *integer32; 762 CHECK_STACK(2, 0); 763 integer32 = (ficlUnsigned32 *)(dataTop--)->p; 764 *integer32 = (ficlUnsigned32)((dataTop--)->u); 765 continue; 766 } 767 768 case ficlInstructionWFetch: { 769 ficlUnsigned16 *integer16; 770 CHECK_STACK(1, 1); 771 integer16 = (ficlUnsigned16 *)dataTop->p; 772 dataTop->u = ((ficlUnsigned)*integer16); 773 continue; 774 } 775 776 case ficlInstructionWStore: { 777 ficlUnsigned16 *integer16; 778 CHECK_STACK(2, 0); 779 integer16 = (ficlUnsigned16 *)(dataTop--)->p; 780 *integer16 = (ficlUnsigned16)((dataTop--)->u); 781 continue; 782 } 783 784 case ficlInstructionCFetch: { 785 ficlUnsigned8 *integer8; 786 CHECK_STACK(1, 1); 787 integer8 = (ficlUnsigned8 *)dataTop->p; 788 dataTop->u = ((ficlUnsigned)*integer8); 789 continue; 790 } 791 792 case ficlInstructionCStore: { 793 ficlUnsigned8 *integer8; 794 CHECK_STACK(2, 0); 795 integer8 = (ficlUnsigned8 *)(dataTop--)->p; 796 *integer8 = (ficlUnsigned8)((dataTop--)->u); 797 continue; 798 } 799 800 801 /* 802 * l o g i c a n d c o m p a r i s o n s 803 */ 804 805 case ficlInstruction0Equals: 806 CHECK_STACK(1, 1); 807 dataTop->i = FICL_BOOL(dataTop->i == 0); 808 continue; 809 810 case ficlInstruction0Less: 811 CHECK_STACK(1, 1); 812 dataTop->i = FICL_BOOL(dataTop->i < 0); 813 continue; 814 815 case ficlInstruction0Greater: 816 CHECK_STACK(1, 1); 817 dataTop->i = FICL_BOOL(dataTop->i > 0); 818 continue; 819 820 case ficlInstructionEquals: 821 CHECK_STACK(2, 1); 822 i = (dataTop--)->i; 823 dataTop->i = FICL_BOOL(dataTop->i == i); 824 continue; 825 826 case ficlInstructionLess: 827 CHECK_STACK(2, 1); 828 i = (dataTop--)->i; 829 dataTop->i = FICL_BOOL(dataTop->i < i); 830 continue; 831 832 case ficlInstructionULess: 833 CHECK_STACK(2, 1); 834 u = (dataTop--)->u; 835 dataTop->i = FICL_BOOL(dataTop->u < u); 836 continue; 837 838 case ficlInstructionAnd: 839 CHECK_STACK(2, 1); 840 i = (dataTop--)->i; 841 dataTop->i = dataTop->i & i; 842 continue; 843 844 case ficlInstructionOr: 845 CHECK_STACK(2, 1); 846 i = (dataTop--)->i; 847 dataTop->i = dataTop->i | i; 848 continue; 849 850 case ficlInstructionXor: 851 CHECK_STACK(2, 1); 852 i = (dataTop--)->i; 853 dataTop->i = dataTop->i ^ i; 854 continue; 855 856 case ficlInstructionInvert: 857 CHECK_STACK(1, 1); 858 dataTop->i = ~dataTop->i; 859 continue; 860 861 /* 862 * r e t u r n s t a c k 863 */ 864 case ficlInstructionToRStack: 865 CHECK_STACK(1, 0); 866 CHECK_RETURN_STACK(0, 1); 867 *++returnTop = *dataTop--; 868 continue; 869 870 case ficlInstructionFromRStack: 871 CHECK_STACK(0, 1); 872 CHECK_RETURN_STACK(1, 0); 873 *++dataTop = *returnTop--; 874 continue; 875 876 case ficlInstructionFetchRStack: 877 CHECK_STACK(0, 1); 878 CHECK_RETURN_STACK(1, 1); 879 *++dataTop = *returnTop; 880 continue; 881 882 case ficlInstruction2ToR: 883 CHECK_STACK(2, 0); 884 CHECK_RETURN_STACK(0, 2); 885 *++returnTop = dataTop[-1]; 886 *++returnTop = dataTop[0]; 887 dataTop -= 2; 888 continue; 889 890 case ficlInstruction2RFrom: 891 CHECK_STACK(0, 2); 892 CHECK_RETURN_STACK(2, 0); 893 *++dataTop = returnTop[-1]; 894 *++dataTop = returnTop[0]; 895 returnTop -= 2; 896 continue; 897 898 case ficlInstruction2RFetch: 899 CHECK_STACK(0, 2); 900 CHECK_RETURN_STACK(2, 2); 901 *++dataTop = returnTop[-1]; 902 *++dataTop = returnTop[0]; 903 continue; 904 905 /* 906 * f i l l 907 * CORE ( c-addr u char -- ) 908 * If u is greater than zero, store char in each of u 909 * consecutive characters of memory beginning at c-addr. 910 */ 911 case ficlInstructionFill: { 912 char c; 913 char *memory; 914 CHECK_STACK(3, 0); 915 c = (char)(dataTop--)->i; 916 u = (dataTop--)->u; 917 memory = (char *)(dataTop--)->p; 918 919 /* 920 * memset() is faster than the previous hand-rolled 921 * solution. --lch 922 */ 923 memset(memory, c, u); 924 continue; 925 } 926 927 /* 928 * l s h i f t 929 * l-shift CORE ( x1 u -- x2 ) 930 * Perform a logical left shift of u bit-places on x1, 931 * giving x2. Put zeroes into the least significant bits 932 * vacated by the shift. An ambiguous condition exists if 933 * u is greater than or equal to the number of bits in a 934 * ficlCell. 935 * 936 * r-shift CORE ( x1 u -- x2 ) 937 * Perform a logical right shift of u bit-places on x1, 938 * giving x2. Put zeroes into the most significant bits 939 * vacated by the shift. An ambiguous condition exists 940 * if u is greater than or equal to the number of bits 941 * in a ficlCell. 942 */ 943 case ficlInstructionLShift: { 944 ficlUnsigned nBits; 945 ficlUnsigned x1; 946 CHECK_STACK(2, 1); 947 948 nBits = (dataTop--)->u; 949 x1 = dataTop->u; 950 dataTop->u = x1 << nBits; 951 continue; 952 } 953 954 case ficlInstructionRShift: { 955 ficlUnsigned nBits; 956 ficlUnsigned x1; 957 CHECK_STACK(2, 1); 958 959 nBits = (dataTop--)->u; 960 x1 = dataTop->u; 961 dataTop->u = x1 >> nBits; 962 continue; 963 } 964 965 /* 966 * m a x & m i n 967 */ 968 case ficlInstructionMax: { 969 ficlInteger n2; 970 ficlInteger n1; 971 CHECK_STACK(2, 1); 972 973 n2 = (dataTop--)->i; 974 n1 = dataTop->i; 975 976 dataTop->i = ((n1 > n2) ? n1 : n2); 977 continue; 978 } 979 980 case ficlInstructionMin: { 981 ficlInteger n2; 982 ficlInteger n1; 983 CHECK_STACK(2, 1); 984 985 n2 = (dataTop--)->i; 986 n1 = dataTop->i; 987 988 dataTop->i = ((n1 < n2) ? n1 : n2); 989 continue; 990 } 991 992 /* 993 * m o v e 994 * CORE ( addr1 addr2 u -- ) 995 * If u is greater than zero, copy the contents of u 996 * consecutive address units at addr1 to the u consecutive 997 * address units at addr2. After MOVE completes, the u 998 * consecutive address units at addr2 contain exactly 999 * what the u consecutive address units at addr1 contained 1000 * before the move. 1001 * NOTE! This implementation assumes that a char is the same 1002 * size as an address unit. 1003 */ 1004 case ficlInstructionMove: { 1005 ficlUnsigned u; 1006 char *addr2; 1007 char *addr1; 1008 CHECK_STACK(3, 0); 1009 1010 u = (dataTop--)->u; 1011 addr2 = (dataTop--)->p; 1012 addr1 = (dataTop--)->p; 1013 1014 if (u == 0) 1015 continue; 1016 /* 1017 * Do the copy carefully, so as to be 1018 * correct even if the two ranges overlap 1019 */ 1020 /* Which ANSI C's memmove() does for you! Yay! --lch */ 1021 memmove(addr2, addr1, u); 1022 continue; 1023 } 1024 1025 /* 1026 * s t o d 1027 * s-to-d CORE ( n -- d ) 1028 * Convert the number n to the double-ficlCell number d with 1029 * the same numerical value. 1030 */ 1031 case ficlInstructionSToD: { 1032 ficlInteger s; 1033 CHECK_STACK(1, 2); 1034 1035 s = dataTop->i; 1036 1037 /* sign extend to 64 bits.. */ 1038 (++dataTop)->i = (s < 0) ? -1 : 0; 1039 continue; 1040 } 1041 1042 /* 1043 * c o m p a r e 1044 * STRING ( c-addr1 u1 c-addr2 u2 -- n ) 1045 * Compare the string specified by c-addr1 u1 to the string 1046 * specified by c-addr2 u2. The strings are compared, beginning 1047 * at the given addresses, character by character, up to the 1048 * length of the shorter string or until a difference is found. 1049 * If the two strings are identical, n is zero. If the two 1050 * strings are identical up to the length of the shorter string, 1051 * n is minus-one (-1) if u1 is less than u2 and one (1) 1052 * otherwise. If the two strings are not identical up to the 1053 * length of the shorter string, n is minus-one (-1) if the 1054 * first non-matching character in the string specified by 1055 * c-addr1 u1 has a lesser numeric value than the corresponding 1056 * character in the string specified by c-addr2 u2 and 1057 * one (1) otherwise. 1058 */ 1059 case ficlInstructionCompare: 1060 i = FICL_FALSE; 1061 goto COMPARE; 1062 1063 1064 case ficlInstructionCompareInsensitive: 1065 i = FICL_TRUE; 1066 goto COMPARE; 1067 1068 COMPARE: 1069 { 1070 char *cp1, *cp2; 1071 ficlUnsigned u1, u2, uMin; 1072 int n = 0; 1073 1074 CHECK_STACK(4, 1); 1075 u2 = (dataTop--)->u; 1076 cp2 = (char *)(dataTop--)->p; 1077 u1 = (dataTop--)->u; 1078 cp1 = (char *)(dataTop--)->p; 1079 1080 uMin = (u1 < u2)? u1 : u2; 1081 for (; (uMin > 0) && (n == 0); uMin--) { 1082 int c1 = (unsigned char)*cp1++; 1083 int c2 = (unsigned char)*cp2++; 1084 1085 if (i) { 1086 c1 = tolower(c1); 1087 c2 = tolower(c2); 1088 } 1089 n = (c1 - c2); 1090 } 1091 1092 if (n == 0) 1093 n = (int)(u1 - u2); 1094 1095 if (n < 0) 1096 n = -1; 1097 else if (n > 0) 1098 n = 1; 1099 1100 (++dataTop)->i = n; 1101 continue; 1102 } 1103 1104 /* 1105 * r a n d o m 1106 * Ficl-specific 1107 */ 1108 case ficlInstructionRandom: 1109 (++dataTop)->i = random(); 1110 continue; 1111 1112 /* 1113 * s e e d - r a n d o m 1114 * Ficl-specific 1115 */ 1116 case ficlInstructionSeedRandom: 1117 srandom((dataTop--)->i); 1118 continue; 1119 1120 case ficlInstructionGreaterThan: { 1121 ficlInteger x, y; 1122 CHECK_STACK(2, 1); 1123 y = (dataTop--)->i; 1124 x = dataTop->i; 1125 dataTop->i = FICL_BOOL(x > y); 1126 continue; 1127 1128 case ficlInstructionUGreaterThan: 1129 CHECK_STACK(2, 1); 1130 u = (dataTop--)->u; 1131 dataTop->i = FICL_BOOL(dataTop->u > u); 1132 continue; 1133 1134 } 1135 1136 /* 1137 * This function simply pops the previous instruction 1138 * pointer and returns to the "next" loop. Used for exiting 1139 * from within a definition. Note that exitParen is identical 1140 * to semiParen - they are in two different functions so that 1141 * "see" can correctly identify the end of a colon definition, 1142 * even if it uses "exit". 1143 */ 1144 case ficlInstructionExitParen: 1145 case ficlInstructionSemiParen: 1146 EXIT_FUNCTION(); 1147 1148 /* 1149 * The first time we run "(branch)", perform a "peephole 1150 * optimization" to see if we're jumping to another 1151 * unconditional jump. If so, just jump directly there. 1152 */ 1153 case ficlInstructionBranchParenWithCheck: 1154 LOCAL_VARIABLE_SPILL; 1155 ficlVmOptimizeJumpToJump(vm, vm->ip - 1); 1156 LOCAL_VARIABLE_REFILL; 1157 goto BRANCH_PAREN; 1158 1159 /* 1160 * Same deal with branch0. 1161 */ 1162 case ficlInstructionBranch0ParenWithCheck: 1163 LOCAL_VARIABLE_SPILL; 1164 ficlVmOptimizeJumpToJump(vm, vm->ip - 1); 1165 LOCAL_VARIABLE_REFILL; 1166 /* intentional fall-through */ 1167 1168 /* 1169 * Runtime code for "(branch0)"; pop a flag from the stack, 1170 * branch if 0. fall through otherwise. 1171 * The heart of "if" and "until". 1172 */ 1173 case ficlInstructionBranch0Paren: 1174 CHECK_STACK(1, 0); 1175 1176 if ((dataTop--)->i) { 1177 /* 1178 * don't branch, but skip over branch 1179 * relative address 1180 */ 1181 ip += 1; 1182 continue; 1183 } 1184 /* otherwise, take branch (to else/endif/begin) */ 1185 /* intentional fall-through! */ 1186 1187 /* 1188 * Runtime for "(branch)" -- expects a literal offset in the 1189 * next compilation address, and branches to that location. 1190 */ 1191 case ficlInstructionBranchParen: 1192 BRANCH_PAREN: 1193 BRANCH(); 1194 1195 case ficlInstructionOfParen: { 1196 ficlUnsigned a, b; 1197 1198 CHECK_STACK(2, 1); 1199 1200 a = (dataTop--)->u; 1201 b = dataTop->u; 1202 1203 if (a == b) { 1204 /* fall through */ 1205 ip++; 1206 /* remove CASE argument */ 1207 dataTop--; 1208 } else { 1209 /* take branch to next of or endcase */ 1210 BRANCH(); 1211 } 1212 1213 continue; 1214 } 1215 1216 case ficlInstructionDoParen: { 1217 ficlCell index, limit; 1218 1219 CHECK_STACK(2, 0); 1220 1221 index = *dataTop--; 1222 limit = *dataTop--; 1223 1224 /* copy "leave" target addr to stack */ 1225 (++returnTop)->i = *(ip++); 1226 *++returnTop = limit; 1227 *++returnTop = index; 1228 1229 continue; 1230 } 1231 1232 case ficlInstructionQDoParen: { 1233 ficlCell index, limit, leave; 1234 1235 CHECK_STACK(2, 0); 1236 1237 index = *dataTop--; 1238 limit = *dataTop--; 1239 1240 leave.i = *ip; 1241 1242 if (limit.u == index.u) { 1243 ip = leave.p; 1244 } else { 1245 ip++; 1246 *++returnTop = leave; 1247 *++returnTop = limit; 1248 *++returnTop = index; 1249 } 1250 1251 continue; 1252 } 1253 1254 case ficlInstructionLoopParen: 1255 case ficlInstructionPlusLoopParen: { 1256 ficlInteger index; 1257 ficlInteger limit; 1258 int direction = 0; 1259 1260 index = returnTop->i; 1261 limit = returnTop[-1].i; 1262 1263 if (instruction == ficlInstructionLoopParen) 1264 index++; 1265 else { 1266 ficlInteger increment; 1267 CHECK_STACK(1, 0); 1268 increment = (dataTop--)->i; 1269 index += increment; 1270 direction = (increment < 0); 1271 } 1272 1273 if (direction ^ (index >= limit)) { 1274 /* nuke the loop indices & "leave" addr */ 1275 returnTop -= 3; 1276 ip++; /* fall through the loop */ 1277 } else { /* update index, branch to loop head */ 1278 returnTop->i = index; 1279 BRANCH(); 1280 } 1281 1282 continue; 1283 } 1284 1285 1286 /* 1287 * Runtime code to break out of a do..loop construct 1288 * Drop the loop control variables; the branch address 1289 * past "loop" is next on the return stack. 1290 */ 1291 case ficlInstructionLeave: 1292 /* almost unloop */ 1293 returnTop -= 2; 1294 /* exit */ 1295 EXIT_FUNCTION(); 1296 1297 case ficlInstructionUnloop: 1298 returnTop -= 3; 1299 continue; 1300 1301 case ficlInstructionI: 1302 *++dataTop = *returnTop; 1303 continue; 1304 1305 case ficlInstructionJ: 1306 *++dataTop = returnTop[-3]; 1307 continue; 1308 1309 case ficlInstructionK: 1310 *++dataTop = returnTop[-6]; 1311 continue; 1312 1313 case ficlInstructionDoesParen: { 1314 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1315 dictionary->smudge->code = 1316 (ficlPrimitive)ficlInstructionDoDoes; 1317 dictionary->smudge->param[0].p = ip; 1318 ip = (ficlInstruction *)((returnTop--)->p); 1319 continue; 1320 } 1321 1322 case ficlInstructionDoDoes: { 1323 ficlCell *cell; 1324 ficlIp tempIP; 1325 1326 CHECK_STACK(0, 1); 1327 1328 cell = fw->param; 1329 tempIP = (ficlIp)((*cell).p); 1330 (++dataTop)->p = (cell + 1); 1331 (++returnTop)->p = (void *)ip; 1332 ip = (ficlInstruction *)tempIP; 1333 continue; 1334 } 1335 1336 #if FICL_WANT_FLOAT 1337 case ficlInstructionF2Fetch: 1338 CHECK_FLOAT_STACK(0, 2); 1339 CHECK_STACK(1, 0); 1340 FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); 1341 1342 case ficlInstructionFFetch: 1343 CHECK_FLOAT_STACK(0, 1); 1344 CHECK_STACK(1, 0); 1345 FLOAT_PUSH_CELL_POINTER((dataTop--)->p); 1346 1347 case ficlInstructionF2Store: 1348 CHECK_FLOAT_STACK(2, 0); 1349 CHECK_STACK(1, 0); 1350 FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p); 1351 1352 case ficlInstructionFStore: 1353 CHECK_FLOAT_STACK(1, 0); 1354 CHECK_STACK(1, 0); 1355 FLOAT_POP_CELL_POINTER((dataTop--)->p); 1356 #endif /* FICL_WANT_FLOAT */ 1357 1358 /* 1359 * two-fetch CORE ( a-addr -- x1 x2 ) 1360 * 1361 * Fetch the ficlCell pair x1 x2 stored at a-addr. 1362 * x2 is stored at a-addr and x1 at the next consecutive 1363 * ficlCell. It is equivalent to the sequence 1364 * DUP ficlCell+ @ SWAP @ . 1365 */ 1366 case ficlInstruction2Fetch: 1367 CHECK_STACK(1, 2); 1368 PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); 1369 1370 /* 1371 * fetch CORE ( a-addr -- x ) 1372 * 1373 * x is the value stored at a-addr. 1374 */ 1375 case ficlInstructionFetch: 1376 CHECK_STACK(1, 1); 1377 PUSH_CELL_POINTER((dataTop--)->p); 1378 1379 /* 1380 * two-store CORE ( x1 x2 a-addr -- ) 1381 * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr 1382 * and x1 at the next consecutive ficlCell. It is equivalent 1383 * to the sequence SWAP OVER ! ficlCell+ ! 1384 */ 1385 case ficlInstruction2Store: 1386 CHECK_STACK(3, 0); 1387 POP_CELL_POINTER_DOUBLE((dataTop--)->p); 1388 1389 /* 1390 * store CORE ( x a-addr -- ) 1391 * Store x at a-addr. 1392 */ 1393 case ficlInstructionStore: 1394 CHECK_STACK(2, 0); 1395 POP_CELL_POINTER((dataTop--)->p); 1396 1397 case ficlInstructionComma: { 1398 ficlDictionary *dictionary; 1399 CHECK_STACK(1, 0); 1400 1401 dictionary = ficlVmGetDictionary(vm); 1402 ficlDictionaryAppendCell(dictionary, *dataTop--); 1403 continue; 1404 } 1405 1406 case ficlInstructionCComma: { 1407 ficlDictionary *dictionary; 1408 char c; 1409 CHECK_STACK(1, 0); 1410 1411 dictionary = ficlVmGetDictionary(vm); 1412 c = (char)(dataTop--)->i; 1413 ficlDictionaryAppendCharacter(dictionary, c); 1414 continue; 1415 } 1416 1417 case ficlInstructionCells: 1418 CHECK_STACK(1, 1); 1419 dataTop->i *= sizeof (ficlCell); 1420 continue; 1421 1422 case ficlInstructionCellPlus: 1423 CHECK_STACK(1, 1); 1424 dataTop->i += sizeof (ficlCell); 1425 continue; 1426 1427 case ficlInstructionStar: 1428 CHECK_STACK(2, 1); 1429 i = (dataTop--)->i; 1430 dataTop->i *= i; 1431 continue; 1432 1433 case ficlInstructionNegate: 1434 CHECK_STACK(1, 1); 1435 dataTop->i = - dataTop->i; 1436 continue; 1437 1438 case ficlInstructionSlash: 1439 CHECK_STACK(2, 1); 1440 i = (dataTop--)->i; 1441 dataTop->i /= i; 1442 continue; 1443 1444 /* 1445 * slash-mod CORE ( n1 n2 -- n3 n4 ) 1446 * Divide n1 by n2, giving the single-ficlCell remainder n3 1447 * and the single-ficlCell quotient n4. An ambiguous condition 1448 * exists if n2 is zero. If n1 and n2 differ in sign, the 1449 * implementation-defined result returned will be the 1450 * same as that returned by either the phrase 1451 * >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM. 1452 * NOTE: Ficl complies with the second phrase 1453 * (symmetric division) 1454 */ 1455 case ficlInstructionSlashMod: { 1456 ficl2Integer n1; 1457 ficlInteger n2; 1458 ficl2IntegerQR qr; 1459 1460 CHECK_STACK(2, 2); 1461 n2 = dataTop[0].i; 1462 FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1); 1463 1464 qr = ficl2IntegerDivideSymmetric(n1, n2); 1465 dataTop[-1].i = qr.remainder; 1466 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); 1467 continue; 1468 } 1469 1470 case ficlInstruction2Star: 1471 CHECK_STACK(1, 1); 1472 dataTop->i <<= 1; 1473 continue; 1474 1475 case ficlInstruction2Slash: 1476 CHECK_STACK(1, 1); 1477 dataTop->i >>= 1; 1478 continue; 1479 1480 case ficlInstructionStarSlash: { 1481 ficlInteger x, y, z; 1482 ficl2Integer prod; 1483 CHECK_STACK(3, 1); 1484 1485 z = (dataTop--)->i; 1486 y = (dataTop--)->i; 1487 x = dataTop->i; 1488 1489 prod = ficl2IntegerMultiply(x, y); 1490 dataTop->i = FICL_2UNSIGNED_GET_LOW( 1491 ficl2IntegerDivideSymmetric(prod, z).quotient); 1492 continue; 1493 } 1494 1495 case ficlInstructionStarSlashMod: { 1496 ficlInteger x, y, z; 1497 ficl2Integer prod; 1498 ficl2IntegerQR qr; 1499 1500 CHECK_STACK(3, 2); 1501 1502 z = (dataTop--)->i; 1503 y = dataTop[0].i; 1504 x = dataTop[-1].i; 1505 1506 prod = ficl2IntegerMultiply(x, y); 1507 qr = ficl2IntegerDivideSymmetric(prod, z); 1508 1509 dataTop[-1].i = qr.remainder; 1510 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); 1511 continue; 1512 } 1513 1514 #if FICL_WANT_FLOAT 1515 case ficlInstructionF0: 1516 CHECK_FLOAT_STACK(0, 1); 1517 (++floatTop)->f = 0.0f; 1518 continue; 1519 1520 case ficlInstructionF1: 1521 CHECK_FLOAT_STACK(0, 1); 1522 (++floatTop)->f = 1.0f; 1523 continue; 1524 1525 case ficlInstructionFNeg1: 1526 CHECK_FLOAT_STACK(0, 1); 1527 (++floatTop)->f = -1.0f; 1528 continue; 1529 1530 /* 1531 * Floating point literal execution word. 1532 */ 1533 case ficlInstructionFLiteralParen: 1534 CHECK_FLOAT_STACK(0, 1); 1535 1536 /* 1537 * Yes, I'm using ->i here, 1538 * but it's really a float. --lch 1539 */ 1540 (++floatTop)->i = *ip++; 1541 continue; 1542 1543 /* 1544 * Do float addition r1 + r2. 1545 * f+ ( r1 r2 -- r ) 1546 */ 1547 case ficlInstructionFPlus: 1548 CHECK_FLOAT_STACK(2, 1); 1549 1550 f = (floatTop--)->f; 1551 floatTop->f += f; 1552 continue; 1553 1554 /* 1555 * Do float subtraction r1 - r2. 1556 * f- ( r1 r2 -- r ) 1557 */ 1558 case ficlInstructionFMinus: 1559 CHECK_FLOAT_STACK(2, 1); 1560 1561 f = (floatTop--)->f; 1562 floatTop->f -= f; 1563 continue; 1564 1565 /* 1566 * Do float multiplication r1 * r2. 1567 * f* ( r1 r2 -- r ) 1568 */ 1569 case ficlInstructionFStar: 1570 CHECK_FLOAT_STACK(2, 1); 1571 1572 f = (floatTop--)->f; 1573 floatTop->f *= f; 1574 continue; 1575 1576 /* 1577 * Do float negation. 1578 * fnegate ( r -- r ) 1579 */ 1580 case ficlInstructionFNegate: 1581 CHECK_FLOAT_STACK(1, 1); 1582 1583 floatTop->f = -(floatTop->f); 1584 continue; 1585 1586 /* 1587 * Do float division r1 / r2. 1588 * f/ ( r1 r2 -- r ) 1589 */ 1590 case ficlInstructionFSlash: 1591 CHECK_FLOAT_STACK(2, 1); 1592 1593 f = (floatTop--)->f; 1594 floatTop->f /= f; 1595 continue; 1596 1597 /* 1598 * Do float + integer r + n. 1599 * f+i ( r n -- r ) 1600 */ 1601 case ficlInstructionFPlusI: 1602 CHECK_FLOAT_STACK(1, 1); 1603 CHECK_STACK(1, 0); 1604 1605 f = (ficlFloat)(dataTop--)->f; 1606 floatTop->f += f; 1607 continue; 1608 1609 /* 1610 * Do float - integer r - n. 1611 * f-i ( r n -- r ) 1612 */ 1613 case ficlInstructionFMinusI: 1614 CHECK_FLOAT_STACK(1, 1); 1615 CHECK_STACK(1, 0); 1616 1617 f = (ficlFloat)(dataTop--)->f; 1618 floatTop->f -= f; 1619 continue; 1620 1621 /* 1622 * Do float * integer r * n. 1623 * f*i ( r n -- r ) 1624 */ 1625 case ficlInstructionFStarI: 1626 CHECK_FLOAT_STACK(1, 1); 1627 CHECK_STACK(1, 0); 1628 1629 f = (ficlFloat)(dataTop--)->f; 1630 floatTop->f *= f; 1631 continue; 1632 1633 /* 1634 * Do float / integer r / n. 1635 * f/i ( r n -- r ) 1636 */ 1637 case ficlInstructionFSlashI: 1638 CHECK_FLOAT_STACK(1, 1); 1639 CHECK_STACK(1, 0); 1640 1641 f = (ficlFloat)(dataTop--)->f; 1642 floatTop->f /= f; 1643 continue; 1644 1645 /* 1646 * Do integer - float n - r. 1647 * i-f ( n r -- r ) 1648 */ 1649 case ficlInstructionIMinusF: 1650 CHECK_FLOAT_STACK(1, 1); 1651 CHECK_STACK(1, 0); 1652 1653 f = (ficlFloat)(dataTop--)->f; 1654 floatTop->f = f - floatTop->f; 1655 continue; 1656 1657 /* 1658 * Do integer / float n / r. 1659 * i/f ( n r -- r ) 1660 */ 1661 case ficlInstructionISlashF: 1662 CHECK_FLOAT_STACK(1, 1); 1663 CHECK_STACK(1, 0); 1664 1665 f = (ficlFloat)(dataTop--)->f; 1666 floatTop->f = f / floatTop->f; 1667 continue; 1668 1669 /* 1670 * Do integer to float conversion. 1671 * int>float ( n -- r ) 1672 */ 1673 case ficlInstructionIntToFloat: 1674 CHECK_STACK(1, 0); 1675 CHECK_FLOAT_STACK(0, 1); 1676 1677 (++floatTop)->f = ((dataTop--)->f); 1678 continue; 1679 1680 /* 1681 * Do float to integer conversion. 1682 * float>int ( r -- n ) 1683 */ 1684 case ficlInstructionFloatToInt: 1685 CHECK_STACK(0, 1); 1686 CHECK_FLOAT_STACK(1, 0); 1687 1688 (++dataTop)->i = ((floatTop--)->i); 1689 continue; 1690 1691 /* 1692 * Add a floating point number to contents of a variable. 1693 * f+! ( r n -- ) 1694 */ 1695 case ficlInstructionFPlusStore: { 1696 ficlCell *cell; 1697 1698 CHECK_STACK(1, 0); 1699 CHECK_FLOAT_STACK(1, 0); 1700 1701 cell = (ficlCell *)(dataTop--)->p; 1702 cell->f += (floatTop--)->f; 1703 continue; 1704 } 1705 1706 /* 1707 * Do float stack drop. 1708 * fdrop ( r -- ) 1709 */ 1710 case ficlInstructionFDrop: 1711 CHECK_FLOAT_STACK(1, 0); 1712 floatTop--; 1713 continue; 1714 1715 /* 1716 * Do float stack ?dup. 1717 * f?dup ( r -- r ) 1718 */ 1719 case ficlInstructionFQuestionDup: 1720 CHECK_FLOAT_STACK(1, 2); 1721 1722 if (floatTop->f != 0) 1723 goto FDUP; 1724 1725 continue; 1726 1727 /* 1728 * Do float stack dup. 1729 * fdup ( r -- r r ) 1730 */ 1731 case ficlInstructionFDup: 1732 CHECK_FLOAT_STACK(1, 2); 1733 1734 FDUP: 1735 floatTop[1] = floatTop[0]; 1736 floatTop++; 1737 continue; 1738 1739 /* 1740 * Do float stack swap. 1741 * fswap ( r1 r2 -- r2 r1 ) 1742 */ 1743 case ficlInstructionFSwap: 1744 CHECK_FLOAT_STACK(2, 2); 1745 1746 c = floatTop[0]; 1747 floatTop[0] = floatTop[-1]; 1748 floatTop[-1] = c; 1749 continue; 1750 1751 /* 1752 * Do float stack 2drop. 1753 * f2drop ( r r -- ) 1754 */ 1755 case ficlInstructionF2Drop: 1756 CHECK_FLOAT_STACK(2, 0); 1757 1758 floatTop -= 2; 1759 continue; 1760 1761 /* 1762 * Do float stack 2dup. 1763 * f2dup ( r1 r2 -- r1 r2 r1 r2 ) 1764 */ 1765 case ficlInstructionF2Dup: 1766 CHECK_FLOAT_STACK(2, 4); 1767 1768 floatTop[1] = floatTop[-1]; 1769 floatTop[2] = *floatTop; 1770 floatTop += 2; 1771 continue; 1772 1773 /* 1774 * Do float stack over. 1775 * fover ( r1 r2 -- r1 r2 r1 ) 1776 */ 1777 case ficlInstructionFOver: 1778 CHECK_FLOAT_STACK(2, 3); 1779 1780 floatTop[1] = floatTop[-1]; 1781 floatTop++; 1782 continue; 1783 1784 /* 1785 * Do float stack 2over. 1786 * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 ) 1787 */ 1788 case ficlInstructionF2Over: 1789 CHECK_FLOAT_STACK(4, 6); 1790 1791 floatTop[1] = floatTop[-2]; 1792 floatTop[2] = floatTop[-1]; 1793 floatTop += 2; 1794 continue; 1795 1796 /* 1797 * Do float stack pick. 1798 * fpick ( n -- r ) 1799 */ 1800 case ficlInstructionFPick: 1801 CHECK_STACK(1, 0); 1802 c = *dataTop--; 1803 CHECK_FLOAT_STACK(c.i+2, c.i+3); 1804 1805 floatTop[1] = floatTop[- c.i - 1]; 1806 continue; 1807 1808 /* 1809 * Do float stack rot. 1810 * frot ( r1 r2 r3 -- r2 r3 r1 ) 1811 */ 1812 case ficlInstructionFRot: 1813 i = 2; 1814 goto FROLL; 1815 1816 /* 1817 * Do float stack roll. 1818 * froll ( n -- ) 1819 */ 1820 case ficlInstructionFRoll: 1821 CHECK_STACK(1, 0); 1822 i = (dataTop--)->i; 1823 1824 if (i < 1) 1825 continue; 1826 1827 FROLL: 1828 CHECK_FLOAT_STACK(i+1, i+2); 1829 c = floatTop[-i]; 1830 memmove(floatTop - i, floatTop - (i - 1), 1831 i * sizeof (ficlCell)); 1832 *floatTop = c; 1833 1834 continue; 1835 1836 /* 1837 * Do float stack -rot. 1838 * f-rot ( r1 r2 r3 -- r3 r1 r2 ) 1839 */ 1840 case ficlInstructionFMinusRot: 1841 i = 2; 1842 goto FMINUSROLL; 1843 1844 1845 /* 1846 * Do float stack -roll. 1847 * f-roll ( n -- ) 1848 */ 1849 case ficlInstructionFMinusRoll: 1850 CHECK_STACK(1, 0); 1851 i = (dataTop--)->i; 1852 1853 if (i < 1) 1854 continue; 1855 1856 FMINUSROLL: 1857 CHECK_FLOAT_STACK(i+1, i+2); 1858 c = *floatTop; 1859 memmove(floatTop - (i - 1), floatTop - i, 1860 i * sizeof (ficlCell)); 1861 floatTop[-i] = c; 1862 1863 continue; 1864 1865 /* 1866 * Do float stack 2swap 1867 * f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 ) 1868 */ 1869 case ficlInstructionF2Swap: { 1870 ficlCell c2; 1871 CHECK_FLOAT_STACK(4, 4); 1872 1873 c = *floatTop; 1874 c2 = floatTop[-1]; 1875 1876 *floatTop = floatTop[-2]; 1877 floatTop[-1] = floatTop[-3]; 1878 1879 floatTop[-2] = c; 1880 floatTop[-3] = c2; 1881 continue; 1882 } 1883 1884 /* 1885 * Do float 0= comparison r = 0.0. 1886 * f0= ( r -- T/F ) 1887 */ 1888 case ficlInstructionF0Equals: 1889 CHECK_FLOAT_STACK(1, 0); 1890 CHECK_STACK(0, 1); 1891 1892 (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f); 1893 continue; 1894 1895 /* 1896 * Do float 0< comparison r < 0.0. 1897 * f0< ( r -- T/F ) 1898 */ 1899 case ficlInstructionF0Less: 1900 CHECK_FLOAT_STACK(1, 0); 1901 CHECK_STACK(0, 1); 1902 1903 (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f); 1904 continue; 1905 1906 /* 1907 * Do float 0> comparison r > 0.0. 1908 * f0> ( r -- T/F ) 1909 */ 1910 case ficlInstructionF0Greater: 1911 CHECK_FLOAT_STACK(1, 0); 1912 CHECK_STACK(0, 1); 1913 1914 (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f); 1915 continue; 1916 1917 /* 1918 * Do float = comparison r1 = r2. 1919 * f= ( r1 r2 -- T/F ) 1920 */ 1921 case ficlInstructionFEquals: 1922 CHECK_FLOAT_STACK(2, 0); 1923 CHECK_STACK(0, 1); 1924 1925 f = (floatTop--)->f; 1926 (++dataTop)->i = FICL_BOOL((floatTop--)->f == f); 1927 continue; 1928 1929 /* 1930 * Do float < comparison r1 < r2. 1931 * f< ( r1 r2 -- T/F ) 1932 */ 1933 case ficlInstructionFLess: 1934 CHECK_FLOAT_STACK(2, 0); 1935 CHECK_STACK(0, 1); 1936 1937 f = (floatTop--)->f; 1938 (++dataTop)->i = FICL_BOOL((floatTop--)->f < f); 1939 continue; 1940 1941 /* 1942 * Do float > comparison r1 > r2. 1943 * f> ( r1 r2 -- T/F ) 1944 */ 1945 case ficlInstructionFGreater: 1946 CHECK_FLOAT_STACK(2, 0); 1947 CHECK_STACK(0, 1); 1948 1949 f = (floatTop--)->f; 1950 (++dataTop)->i = FICL_BOOL((floatTop--)->f > f); 1951 continue; 1952 1953 1954 /* 1955 * Move float to param stack (assumes they both fit in a 1956 * single ficlCell) f>s 1957 */ 1958 case ficlInstructionFFrom: 1959 CHECK_FLOAT_STACK(1, 0); 1960 CHECK_STACK(0, 1); 1961 1962 *++dataTop = *floatTop--; 1963 continue; 1964 1965 case ficlInstructionToF: 1966 CHECK_FLOAT_STACK(0, 1); 1967 CHECK_STACK(1, 0); 1968 1969 *++floatTop = *dataTop--; 1970 continue; 1971 1972 #endif /* FICL_WANT_FLOAT */ 1973 1974 /* 1975 * c o l o n P a r e n 1976 * This is the code that executes a colon definition. It 1977 * assumes that the virtual machine is running a "next" loop 1978 * (See the vm.c for its implementation of member function 1979 * vmExecute()). The colon code simply copies the address of 1980 * the first word in the list of words to interpret into IP 1981 * after saving its old value. When we return to the "next" 1982 * loop, the virtual machine will call the code for each 1983 * word in turn. 1984 */ 1985 case ficlInstructionColonParen: 1986 (++returnTop)->p = (void *)ip; 1987 ip = (ficlInstruction *)(fw->param); 1988 continue; 1989 1990 case ficlInstructionCreateParen: 1991 CHECK_STACK(0, 1); 1992 (++dataTop)->p = (fw->param + 1); 1993 continue; 1994 1995 case ficlInstructionVariableParen: 1996 CHECK_STACK(0, 1); 1997 (++dataTop)->p = fw->param; 1998 continue; 1999 2000 /* 2001 * c o n s t a n t P a r e n 2002 * This is the run-time code for "constant". It simply returns 2003 * the contents of its word's first data ficlCell. 2004 */ 2005 2006 #if FICL_WANT_FLOAT 2007 case ficlInstructionF2ConstantParen: 2008 CHECK_FLOAT_STACK(0, 2); 2009 FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param); 2010 2011 case ficlInstructionFConstantParen: 2012 CHECK_FLOAT_STACK(0, 1); 2013 FLOAT_PUSH_CELL_POINTER(fw->param); 2014 #endif /* FICL_WANT_FLOAT */ 2015 2016 case ficlInstruction2ConstantParen: 2017 CHECK_STACK(0, 2); 2018 PUSH_CELL_POINTER_DOUBLE(fw->param); 2019 2020 case ficlInstructionConstantParen: 2021 CHECK_STACK(0, 1); 2022 PUSH_CELL_POINTER(fw->param); 2023 2024 #if FICL_WANT_USER 2025 case ficlInstructionUserParen: { 2026 ficlInteger i = fw->param[0].i; 2027 (++dataTop)->p = &vm->user[i]; 2028 continue; 2029 } 2030 #endif 2031 2032 default: 2033 /* 2034 * Clever hack, or evil coding? You be the judge. 2035 * 2036 * If the word we've been asked to execute is in fact 2037 * an *instruction*, we grab the instruction, stow it 2038 * in "i" (our local cache of *ip), and *jump* to the 2039 * top of the switch statement. --lch 2040 */ 2041 if (((ficlInstruction)fw->code > 2042 ficlInstructionInvalid) && 2043 ((ficlInstruction)fw->code < ficlInstructionLast)) { 2044 instruction = (ficlInstruction)fw->code; 2045 goto AGAIN; 2046 } 2047 2048 LOCAL_VARIABLE_SPILL; 2049 (vm)->runningWord = fw; 2050 fw->code(vm); 2051 LOCAL_VARIABLE_REFILL; 2052 continue; 2053 } 2054 } 2055 2056 LOCAL_VARIABLE_SPILL; 2057 vm->exceptionHandler = oldExceptionHandler; 2058 } 2059 2060 /* 2061 * v m G e t D i c t 2062 * Returns the address dictionary for this VM's system 2063 */ 2064 ficlDictionary * 2065 ficlVmGetDictionary(ficlVm *vm) 2066 { 2067 FICL_VM_ASSERT(vm, vm); 2068 return (vm->callback.system->dictionary); 2069 } 2070 2071 /* 2072 * v m G e t S t r i n g 2073 * Parses a string out of the VM input buffer and copies up to the first 2074 * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a 2075 * ficlCountedString. The destination string is NULL terminated. 2076 * 2077 * Returns the address of the first unused character in the dest buffer. 2078 */ 2079 char * 2080 ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter) 2081 { 2082 ficlString s = ficlVmParseStringEx(vm, delimiter, 0); 2083 2084 if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) { 2085 FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX); 2086 } 2087 2088 strncpy(counted->text, FICL_STRING_GET_POINTER(s), 2089 FICL_STRING_GET_LENGTH(s)); 2090 counted->text[FICL_STRING_GET_LENGTH(s)] = '\0'; 2091 counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); 2092 2093 return (counted->text + FICL_STRING_GET_LENGTH(s) + 1); 2094 } 2095 2096 /* 2097 * v m G e t W o r d 2098 * vmGetWord calls vmGetWord0 repeatedly until it gets a string with 2099 * non-zero length. 2100 */ 2101 ficlString 2102 ficlVmGetWord(ficlVm *vm) 2103 { 2104 ficlString s = ficlVmGetWord0(vm); 2105 2106 if (FICL_STRING_GET_LENGTH(s) == 0) { 2107 ficlVmThrow(vm, FICL_VM_STATUS_RESTART); 2108 } 2109 2110 return (s); 2111 } 2112 2113 /* 2114 * v m G e t W o r d 0 2115 * Skip leading whitespace and parse a space delimited word from the tib. 2116 * Returns the start address and length of the word. Updates the tib 2117 * to reflect characters consumed, including the trailing delimiter. 2118 * If there's nothing of interest in the tib, returns zero. This function 2119 * does not use vmParseString because it uses isspace() rather than a 2120 * single delimiter character. 2121 */ 2122 ficlString 2123 ficlVmGetWord0(ficlVm *vm) 2124 { 2125 char *trace = ficlVmGetInBuf(vm); 2126 char *stop = ficlVmGetInBufEnd(vm); 2127 ficlString s; 2128 ficlUnsigned length = 0; 2129 char c = 0; 2130 2131 trace = ficlStringSkipSpace(trace, stop); 2132 FICL_STRING_SET_POINTER(s, trace); 2133 2134 /* Please leave this loop this way; it makes Purify happier. --lch */ 2135 for (;;) { 2136 if (trace == stop) 2137 break; 2138 c = *trace; 2139 if (isspace((unsigned char)c)) 2140 break; 2141 length++; 2142 trace++; 2143 } 2144 2145 FICL_STRING_SET_LENGTH(s, length); 2146 2147 /* skip one trailing delimiter */ 2148 if ((trace != stop) && isspace((unsigned char)c)) 2149 trace++; 2150 2151 ficlVmUpdateTib(vm, trace); 2152 2153 return (s); 2154 } 2155 2156 /* 2157 * v m G e t W o r d T o P a d 2158 * Does vmGetWord and copies the result to the pad as a NULL terminated 2159 * string. Returns the length of the string. If the string is too long 2160 * to fit in the pad, it is truncated. 2161 */ 2162 int 2163 ficlVmGetWordToPad(ficlVm *vm) 2164 { 2165 ficlString s; 2166 char *pad = (char *)vm->pad; 2167 s = ficlVmGetWord(vm); 2168 2169 if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE) 2170 FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE); 2171 2172 strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s)); 2173 pad[FICL_STRING_GET_LENGTH(s)] = '\0'; 2174 return ((int)(FICL_STRING_GET_LENGTH(s))); 2175 } 2176 2177 /* 2178 * v m P a r s e S t r i n g 2179 * Parses a string out of the input buffer using the delimiter 2180 * specified. Skips leading delimiters, marks the start of the string, 2181 * and counts characters to the next delimiter it encounters. It then 2182 * updates the vm input buffer to consume all these chars, including the 2183 * trailing delimiter. 2184 * Returns the address and length of the parsed string, not including the 2185 * trailing delimiter. 2186 */ 2187 ficlString 2188 ficlVmParseString(ficlVm *vm, char delimiter) 2189 { 2190 return (ficlVmParseStringEx(vm, delimiter, 1)); 2191 } 2192 2193 ficlString 2194 ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters) 2195 { 2196 ficlString s; 2197 char *trace = ficlVmGetInBuf(vm); 2198 char *stop = ficlVmGetInBufEnd(vm); 2199 char c; 2200 2201 if (skipLeadingDelimiters) { 2202 while ((trace != stop) && (*trace == delimiter)) 2203 trace++; 2204 } 2205 2206 FICL_STRING_SET_POINTER(s, trace); /* mark start of text */ 2207 2208 /* find next delimiter or end of line */ 2209 for (c = *trace; 2210 (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n'); 2211 c = *++trace) { 2212 ; 2213 } 2214 2215 /* set length of result */ 2216 FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s)); 2217 2218 /* gobble trailing delimiter */ 2219 if ((trace != stop) && (*trace == delimiter)) 2220 trace++; 2221 2222 ficlVmUpdateTib(vm, trace); 2223 return (s); 2224 } 2225 2226 2227 /* 2228 * v m P o p 2229 */ 2230 ficlCell 2231 ficlVmPop(ficlVm *vm) 2232 { 2233 return (ficlStackPop(vm->dataStack)); 2234 } 2235 2236 /* 2237 * v m P u s h 2238 */ 2239 void 2240 ficlVmPush(ficlVm *vm, ficlCell c) 2241 { 2242 ficlStackPush(vm->dataStack, c); 2243 } 2244 2245 /* 2246 * v m P o p I P 2247 */ 2248 void 2249 ficlVmPopIP(ficlVm *vm) 2250 { 2251 vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack)); 2252 } 2253 2254 /* 2255 * v m P u s h I P 2256 */ 2257 void 2258 ficlVmPushIP(ficlVm *vm, ficlIp newIP) 2259 { 2260 ficlStackPushPointer(vm->returnStack, (void *)vm->ip); 2261 vm->ip = newIP; 2262 } 2263 2264 /* 2265 * v m P u s h T i b 2266 * Binds the specified input string to the VM and clears >IN (the index) 2267 */ 2268 void 2269 ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib) 2270 { 2271 if (pSaveTib) { 2272 *pSaveTib = vm->tib; 2273 } 2274 vm->tib.text = text; 2275 vm->tib.end = text + nChars; 2276 vm->tib.index = 0; 2277 } 2278 2279 void 2280 ficlVmPopTib(ficlVm *vm, ficlTIB *pTib) 2281 { 2282 if (pTib) { 2283 vm->tib = *pTib; 2284 } 2285 } 2286 2287 /* 2288 * v m Q u i t 2289 */ 2290 void 2291 ficlVmQuit(ficlVm *vm) 2292 { 2293 ficlStackReset(vm->returnStack); 2294 vm->restart = 0; 2295 vm->ip = NULL; 2296 vm->runningWord = NULL; 2297 vm->state = FICL_VM_STATE_INTERPRET; 2298 vm->tib.text = NULL; 2299 vm->tib.end = NULL; 2300 vm->tib.index = 0; 2301 vm->pad[0] = '\0'; 2302 vm->sourceId.i = 0; 2303 } 2304 2305 /* 2306 * v m R e s e t 2307 */ 2308 void 2309 ficlVmReset(ficlVm *vm) 2310 { 2311 ficlVmQuit(vm); 2312 ficlStackReset(vm->dataStack); 2313 #if FICL_WANT_FLOAT 2314 ficlStackReset(vm->floatStack); 2315 #endif 2316 vm->base = 10; 2317 } 2318 2319 /* 2320 * v m S e t T e x t O u t 2321 * Binds the specified output callback to the vm. If you pass NULL, 2322 * binds the default output function (ficlTextOut) 2323 */ 2324 void 2325 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut) 2326 { 2327 vm->callback.textOut = textOut; 2328 } 2329 2330 void 2331 ficlVmTextOut(ficlVm *vm, char *text) 2332 { 2333 ficlCallbackTextOut((ficlCallback *)vm, text); 2334 } 2335 2336 2337 void 2338 ficlVmErrorOut(ficlVm *vm, char *text) 2339 { 2340 ficlCallbackErrorOut((ficlCallback *)vm, text); 2341 } 2342 2343 2344 /* 2345 * v m T h r o w 2346 */ 2347 void 2348 ficlVmThrow(ficlVm *vm, int except) 2349 { 2350 if (vm->exceptionHandler) 2351 longjmp(*(vm->exceptionHandler), except); 2352 } 2353 2354 void 2355 ficlVmThrowError(ficlVm *vm, char *fmt, ...) 2356 { 2357 va_list list; 2358 2359 va_start(list, fmt); 2360 vsprintf(vm->pad, fmt, list); 2361 va_end(list); 2362 strcat(vm->pad, "\n"); 2363 2364 ficlVmErrorOut(vm, vm->pad); 2365 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); 2366 } 2367 2368 void 2369 ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list) 2370 { 2371 vsprintf(vm->pad, fmt, list); 2372 /* 2373 * well, we can try anyway, we're certainly not 2374 * returning to our caller! 2375 */ 2376 va_end(list); 2377 strcat(vm->pad, "\n"); 2378 2379 ficlVmErrorOut(vm, vm->pad); 2380 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); 2381 } 2382 2383 /* 2384 * f i c l E v a l u a t e 2385 * Wrapper for ficlExec() which sets SOURCE-ID to -1. 2386 */ 2387 int 2388 ficlVmEvaluate(ficlVm *vm, char *s) 2389 { 2390 int returnValue; 2391 ficlCell id = vm->sourceId; 2392 ficlString string; 2393 vm->sourceId.i = -1; 2394 FICL_STRING_SET_FROM_CSTRING(string, s); 2395 returnValue = ficlVmExecuteString(vm, string); 2396 vm->sourceId = id; 2397 return (returnValue); 2398 } 2399 2400 /* 2401 * f i c l E x e c 2402 * Evaluates a block of input text in the context of the 2403 * specified interpreter. Emits any requested output to the 2404 * interpreter's output function. 2405 * 2406 * Contains the "inner interpreter" code in a tight loop 2407 * 2408 * Returns one of the VM_XXXX codes defined in ficl.h: 2409 * VM_OUTOFTEXT is the normal exit condition 2410 * VM_ERREXIT means that the interpreter encountered a syntax error 2411 * and the vm has been reset to recover (some or all 2412 * of the text block got ignored 2413 * VM_USEREXIT means that the user executed the "bye" command 2414 * to shut down the interpreter. This would be a good 2415 * time to delete the vm, etc -- or you can ignore this 2416 * signal. 2417 */ 2418 int 2419 ficlVmExecuteString(ficlVm *vm, ficlString s) 2420 { 2421 ficlSystem *system = vm->callback.system; 2422 ficlDictionary *dictionary = system->dictionary; 2423 2424 int except; 2425 jmp_buf vmState; 2426 jmp_buf *oldState; 2427 ficlTIB saveficlTIB; 2428 2429 FICL_VM_ASSERT(vm, vm); 2430 FICL_VM_ASSERT(vm, system->interpreterLoop[0]); 2431 2432 ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s), 2433 FICL_STRING_GET_LENGTH(s), &saveficlTIB); 2434 2435 /* 2436 * Save and restore VM's jmp_buf to enable nested calls to ficlExec 2437 */ 2438 oldState = vm->exceptionHandler; 2439 2440 /* This has to come before the setjmp! */ 2441 vm->exceptionHandler = &vmState; 2442 except = setjmp(vmState); 2443 2444 switch (except) { 2445 case 0: 2446 if (vm->restart) { 2447 vm->runningWord->code(vm); 2448 vm->restart = 0; 2449 } else { /* set VM up to interpret text */ 2450 ficlVmPushIP(vm, &(system->interpreterLoop[0])); 2451 } 2452 2453 ficlVmInnerLoop(vm, 0); 2454 break; 2455 2456 case FICL_VM_STATUS_RESTART: 2457 vm->restart = 1; 2458 except = FICL_VM_STATUS_OUT_OF_TEXT; 2459 break; 2460 2461 case FICL_VM_STATUS_OUT_OF_TEXT: 2462 ficlVmPopIP(vm); 2463 #if 0 /* we dont output prompt in loader */ 2464 if ((vm->state != FICL_VM_STATE_COMPILE) && 2465 (vm->sourceId.i == 0)) 2466 ficlVmTextOut(vm, FICL_PROMPT); 2467 #endif 2468 break; 2469 2470 case FICL_VM_STATUS_USER_EXIT: 2471 case FICL_VM_STATUS_INNER_EXIT: 2472 case FICL_VM_STATUS_BREAK: 2473 break; 2474 2475 case FICL_VM_STATUS_QUIT: 2476 if (vm->state == FICL_VM_STATE_COMPILE) { 2477 ficlDictionaryAbortDefinition(dictionary); 2478 #if FICL_WANT_LOCALS 2479 ficlDictionaryEmpty(system->locals, 2480 system->locals->forthWordlist->size); 2481 #endif 2482 } 2483 ficlVmQuit(vm); 2484 break; 2485 2486 case FICL_VM_STATUS_ERROR_EXIT: 2487 case FICL_VM_STATUS_ABORT: 2488 case FICL_VM_STATUS_ABORTQ: 2489 default: /* user defined exit code?? */ 2490 if (vm->state == FICL_VM_STATE_COMPILE) { 2491 ficlDictionaryAbortDefinition(dictionary); 2492 #if FICL_WANT_LOCALS 2493 ficlDictionaryEmpty(system->locals, 2494 system->locals->forthWordlist->size); 2495 #endif 2496 } 2497 ficlDictionaryResetSearchOrder(dictionary); 2498 ficlVmReset(vm); 2499 break; 2500 } 2501 2502 vm->exceptionHandler = oldState; 2503 ficlVmPopTib(vm, &saveficlTIB); 2504 return (except); 2505 } 2506 2507 /* 2508 * f i c l E x e c X T 2509 * Given a pointer to a ficlWord, push an inner interpreter and 2510 * execute the word to completion. This is in contrast with vmExecute, 2511 * which does not guarantee that the word will have completed when 2512 * the function returns (ie in the case of colon definitions, which 2513 * need an inner interpreter to finish) 2514 * 2515 * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal 2516 * exit condition is VM_INNEREXIT, Ficl's private signal to exit the 2517 * inner loop under normal circumstances. If another code is thrown to 2518 * exit the loop, this function will re-throw it if it's nested under 2519 * itself or ficlExec. 2520 * 2521 * NOTE: this function is intended so that C code can execute ficlWords 2522 * given their address in the dictionary (xt). 2523 */ 2524 int 2525 ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord) 2526 { 2527 int except; 2528 jmp_buf vmState; 2529 jmp_buf *oldState; 2530 ficlWord *oldRunningWord; 2531 2532 FICL_VM_ASSERT(vm, vm); 2533 FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord); 2534 2535 /* 2536 * Save the runningword so that RESTART behaves correctly 2537 * over nested calls. 2538 */ 2539 oldRunningWord = vm->runningWord; 2540 /* 2541 * Save and restore VM's jmp_buf to enable nested calls 2542 */ 2543 oldState = vm->exceptionHandler; 2544 /* This has to come before the setjmp! */ 2545 vm->exceptionHandler = &vmState; 2546 except = setjmp(vmState); 2547 2548 if (except) 2549 ficlVmPopIP(vm); 2550 else 2551 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); 2552 2553 switch (except) { 2554 case 0: 2555 ficlVmExecuteWord(vm, pWord); 2556 ficlVmInnerLoop(vm, 0); 2557 break; 2558 2559 case FICL_VM_STATUS_INNER_EXIT: 2560 case FICL_VM_STATUS_BREAK: 2561 break; 2562 2563 case FICL_VM_STATUS_RESTART: 2564 case FICL_VM_STATUS_OUT_OF_TEXT: 2565 case FICL_VM_STATUS_USER_EXIT: 2566 case FICL_VM_STATUS_QUIT: 2567 case FICL_VM_STATUS_ERROR_EXIT: 2568 case FICL_VM_STATUS_ABORT: 2569 case FICL_VM_STATUS_ABORTQ: 2570 default: /* user defined exit code?? */ 2571 if (oldState) { 2572 vm->exceptionHandler = oldState; 2573 ficlVmThrow(vm, except); 2574 } 2575 break; 2576 } 2577 2578 vm->exceptionHandler = oldState; 2579 vm->runningWord = oldRunningWord; 2580 return (except); 2581 } 2582 2583 /* 2584 * f i c l P a r s e N u m b e r 2585 * Attempts to convert the NULL terminated string in the VM's pad to 2586 * a number using the VM's current base. If successful, pushes the number 2587 * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE. 2588 * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See 2589 * the standard for DOUBLE wordset. 2590 */ 2591 int 2592 ficlVmParseNumber(ficlVm *vm, ficlString s) 2593 { 2594 ficlInteger accumulator = 0; 2595 char isNegative = 0; 2596 char isDouble = 0; 2597 unsigned base = vm->base; 2598 char *trace = FICL_STRING_GET_POINTER(s); 2599 ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); 2600 unsigned c; 2601 unsigned digit; 2602 2603 if (length > 1) { 2604 switch (*trace) { 2605 case '-': 2606 trace++; 2607 length--; 2608 isNegative = 1; 2609 break; 2610 case '+': 2611 trace++; 2612 length--; 2613 isNegative = 0; 2614 break; 2615 default: 2616 break; 2617 } 2618 } 2619 2620 /* detect & remove trailing decimal */ 2621 if ((length > 0) && (trace[length - 1] == '.')) { 2622 isDouble = 1; 2623 length--; 2624 } 2625 2626 if (length == 0) /* detect "+", "-", ".", "+." etc */ 2627 return (0); /* false */ 2628 2629 while ((length--) && ((c = *trace++) != '\0')) { 2630 if (!isalnum(c)) 2631 return (0); /* false */ 2632 2633 digit = c - '0'; 2634 2635 if (digit > 9) 2636 digit = tolower(c) - 'a' + 10; 2637 2638 if (digit >= base) 2639 return (0); /* false */ 2640 2641 accumulator = accumulator * base + digit; 2642 } 2643 2644 if (isNegative) 2645 accumulator = -accumulator; 2646 2647 ficlStackPushInteger(vm->dataStack, accumulator); 2648 if (vm->state == FICL_VM_STATE_COMPILE) 2649 ficlPrimitiveLiteralIm(vm); 2650 2651 if (isDouble) { /* simple (required) DOUBLE support */ 2652 if (isNegative) 2653 ficlStackPushInteger(vm->dataStack, -1); 2654 else 2655 ficlStackPushInteger(vm->dataStack, 0); 2656 if (vm->state == FICL_VM_STATE_COMPILE) 2657 ficlPrimitiveLiteralIm(vm); 2658 } 2659 2660 return (1); /* true */ 2661 } 2662 2663 /* 2664 * d i c t C h e c k 2665 * Checks the dictionary for corruption and throws appropriate 2666 * errors. 2667 * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot 2668 * -n number of ADDRESS UNITS proposed to de-allot 2669 * 0 just do a consistency check 2670 */ 2671 void 2672 ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) 2673 { 2674 #if FICL_ROBUST >= 1 2675 if ((cells >= 0) && 2676 (ficlDictionaryCellsAvailable(dictionary) * 2677 (int)sizeof (ficlCell) < cells)) { 2678 ficlVmThrowError(vm, "Error: dictionary full"); 2679 } 2680 2681 if ((cells <= 0) && 2682 (ficlDictionaryCellsUsed(dictionary) * 2683 (int)sizeof (ficlCell) < -cells)) { 2684 ficlVmThrowError(vm, "Error: dictionary underflow"); 2685 } 2686 #else /* FICL_ROBUST >= 1 */ 2687 FICL_IGNORE(vm); 2688 FICL_IGNORE(dictionary); 2689 FICL_IGNORE(cells); 2690 #endif /* FICL_ROBUST >= 1 */ 2691 } 2692 2693 void 2694 ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) 2695 { 2696 #if FICL_ROBUST >= 1 2697 ficlVmDictionarySimpleCheck(vm, dictionary, cells); 2698 2699 if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) { 2700 ficlDictionaryResetSearchOrder(dictionary); 2701 ficlVmThrowError(vm, "Error: search order overflow"); 2702 } else if (dictionary->wordlistCount < 0) { 2703 ficlDictionaryResetSearchOrder(dictionary); 2704 ficlVmThrowError(vm, "Error: search order underflow"); 2705 } 2706 #else /* FICL_ROBUST >= 1 */ 2707 FICL_IGNORE(vm); 2708 FICL_IGNORE(dictionary); 2709 FICL_IGNORE(cells); 2710 #endif /* FICL_ROBUST >= 1 */ 2711 } 2712 2713 void 2714 ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n) 2715 { 2716 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n); 2717 FICL_IGNORE(vm); 2718 ficlDictionaryAllot(dictionary, n); 2719 } 2720 2721 void 2722 ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells) 2723 { 2724 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells); 2725 FICL_IGNORE(vm); 2726 ficlDictionaryAllotCells(dictionary, cells); 2727 } 2728 2729 /* 2730 * f i c l P a r s e W o r d 2731 * From the standard, section 3.4 2732 * b) Search the dictionary name space (see 3.4.2). If a definition name 2733 * matching the string is found: 2734 * 1.if interpreting, perform the interpretation semantics of the definition 2735 * (see 3.4.3.2), and continue at a); 2736 * 2.if compiling, perform the compilation semantics of the definition 2737 * (see 3.4.3.3), and continue at a). 2738 * 2739 * c) If a definition name matching the string is not found, attempt to 2740 * convert the string to a number (see 3.4.1.3). If successful: 2741 * 1.if interpreting, place the number on the data stack, and continue at a); 2742 * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place 2743 * the number on the stack (see 6.1.1780 LITERAL), and continue at a); 2744 * 2745 * d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 2746 * 2747 * (jws 4/01) Modified to be a ficlParseStep 2748 */ 2749 int 2750 ficlVmParseWord(ficlVm *vm, ficlString name) 2751 { 2752 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2753 ficlWord *tempFW; 2754 2755 FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0); 2756 FICL_STACK_CHECK(vm->dataStack, 0, 0); 2757 2758 #if FICL_WANT_LOCALS 2759 if (vm->callback.system->localsCount > 0) { 2760 tempFW = ficlSystemLookupLocal(vm->callback.system, name); 2761 } else 2762 #endif 2763 tempFW = ficlDictionaryLookup(dictionary, name); 2764 2765 if (vm->state == FICL_VM_STATE_INTERPRET) { 2766 if (tempFW != NULL) { 2767 if (ficlWordIsCompileOnly(tempFW)) { 2768 ficlVmThrowError(vm, 2769 "Error: FICL_VM_STATE_COMPILE only!"); 2770 } 2771 2772 ficlVmExecuteWord(vm, tempFW); 2773 return (1); /* true */ 2774 } 2775 } else { /* (vm->state == FICL_VM_STATE_COMPILE) */ 2776 if (tempFW != NULL) { 2777 if (ficlWordIsImmediate(tempFW)) { 2778 ficlVmExecuteWord(vm, tempFW); 2779 } else { 2780 ficlCell c; 2781 c.p = tempFW; 2782 if (tempFW->flags & FICL_WORD_INSTRUCTION) 2783 ficlDictionaryAppendUnsigned(dictionary, 2784 (ficlInteger)tempFW->code); 2785 else 2786 ficlDictionaryAppendCell(dictionary, c); 2787 } 2788 return (1); /* true */ 2789 } 2790 } 2791 2792 return (0); /* false */ 2793 } 2794