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