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 static 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 volatile int count; /* volatile because of longjmp */ 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 break; 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 continue; 629 } 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 1129 case ficlInstructionUGreaterThan: 1130 CHECK_STACK(2, 1); 1131 u = (dataTop--)->u; 1132 dataTop->i = FICL_BOOL(dataTop->u > u); 1133 continue; 1134 1135 /* 1136 * This function simply pops the previous instruction 1137 * pointer and returns to the "next" loop. Used for exiting 1138 * from within a definition. Note that exitParen is identical 1139 * to semiParen - they are in two different functions so that 1140 * "see" can correctly identify the end of a colon definition, 1141 * even if it uses "exit". 1142 */ 1143 case ficlInstructionExitParen: 1144 case ficlInstructionSemiParen: 1145 EXIT_FUNCTION(); 1146 1147 /* 1148 * The first time we run "(branch)", perform a "peephole 1149 * optimization" to see if we're jumping to another 1150 * unconditional jump. If so, just jump directly there. 1151 */ 1152 case ficlInstructionBranchParenWithCheck: 1153 LOCAL_VARIABLE_SPILL; 1154 ficlVmOptimizeJumpToJump(vm, vm->ip - 1); 1155 LOCAL_VARIABLE_REFILL; 1156 goto BRANCH_PAREN; 1157 1158 /* 1159 * Same deal with branch0. 1160 */ 1161 case ficlInstructionBranch0ParenWithCheck: 1162 LOCAL_VARIABLE_SPILL; 1163 ficlVmOptimizeJumpToJump(vm, vm->ip - 1); 1164 LOCAL_VARIABLE_REFILL; 1165 /* intentional fall-through */ 1166 1167 /* 1168 * Runtime code for "(branch0)"; pop a flag from the stack, 1169 * branch if 0. fall through otherwise. 1170 * The heart of "if" and "until". 1171 */ 1172 case ficlInstructionBranch0Paren: 1173 CHECK_STACK(1, 0); 1174 1175 if ((dataTop--)->i) { 1176 /* 1177 * don't branch, but skip over branch 1178 * relative address 1179 */ 1180 ip += 1; 1181 continue; 1182 } 1183 /* otherwise, take branch (to else/endif/begin) */ 1184 /* intentional fall-through! */ 1185 1186 /* 1187 * Runtime for "(branch)" -- expects a literal offset in the 1188 * next compilation address, and branches to that location. 1189 */ 1190 case ficlInstructionBranchParen: 1191 BRANCH_PAREN: 1192 BRANCH(); 1193 1194 case ficlInstructionOfParen: { 1195 ficlUnsigned a, b; 1196 1197 CHECK_STACK(2, 1); 1198 1199 a = (dataTop--)->u; 1200 b = dataTop->u; 1201 1202 if (a == b) { 1203 /* fall through */ 1204 ip++; 1205 /* remove CASE argument */ 1206 dataTop--; 1207 } else { 1208 /* take branch to next of or endcase */ 1209 BRANCH(); 1210 } 1211 1212 continue; 1213 } 1214 1215 case ficlInstructionDoParen: { 1216 ficlCell index, limit; 1217 1218 CHECK_STACK(2, 0); 1219 1220 index = *dataTop--; 1221 limit = *dataTop--; 1222 1223 /* copy "leave" target addr to stack */ 1224 (++returnTop)->i = *(ip++); 1225 *++returnTop = limit; 1226 *++returnTop = index; 1227 1228 continue; 1229 } 1230 1231 case ficlInstructionQDoParen: { 1232 ficlCell index, limit, leave; 1233 1234 CHECK_STACK(2, 0); 1235 1236 index = *dataTop--; 1237 limit = *dataTop--; 1238 1239 leave.i = *ip; 1240 1241 if (limit.u == index.u) { 1242 ip = leave.p; 1243 } else { 1244 ip++; 1245 *++returnTop = leave; 1246 *++returnTop = limit; 1247 *++returnTop = index; 1248 } 1249 1250 continue; 1251 } 1252 1253 case ficlInstructionLoopParen: 1254 case ficlInstructionPlusLoopParen: { 1255 ficlInteger index; 1256 ficlInteger limit; 1257 int direction = 0; 1258 1259 index = returnTop->i; 1260 limit = returnTop[-1].i; 1261 1262 if (instruction == ficlInstructionLoopParen) 1263 index++; 1264 else { 1265 ficlInteger increment; 1266 CHECK_STACK(1, 0); 1267 increment = (dataTop--)->i; 1268 index += increment; 1269 direction = (increment < 0); 1270 } 1271 1272 if (direction ^ (index >= limit)) { 1273 /* nuke the loop indices & "leave" addr */ 1274 returnTop -= 3; 1275 ip++; /* fall through the loop */ 1276 } else { /* update index, branch to loop head */ 1277 returnTop->i = index; 1278 BRANCH(); 1279 } 1280 1281 continue; 1282 } 1283 1284 1285 /* 1286 * Runtime code to break out of a do..loop construct 1287 * Drop the loop control variables; the branch address 1288 * past "loop" is next on the return stack. 1289 */ 1290 case ficlInstructionLeave: 1291 /* almost unloop */ 1292 returnTop -= 2; 1293 /* exit */ 1294 EXIT_FUNCTION(); 1295 1296 case ficlInstructionUnloop: 1297 returnTop -= 3; 1298 continue; 1299 1300 case ficlInstructionI: 1301 *++dataTop = *returnTop; 1302 continue; 1303 1304 case ficlInstructionJ: 1305 *++dataTop = returnTop[-3]; 1306 continue; 1307 1308 case ficlInstructionK: 1309 *++dataTop = returnTop[-6]; 1310 continue; 1311 1312 case ficlInstructionDoesParen: { 1313 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1314 dictionary->smudge->code = 1315 (ficlPrimitive)ficlInstructionDoDoes; 1316 dictionary->smudge->param[0].p = ip; 1317 ip = (ficlInstruction *)((returnTop--)->p); 1318 continue; 1319 } 1320 1321 case ficlInstructionDoDoes: { 1322 ficlCell *cell; 1323 ficlIp tempIP; 1324 1325 CHECK_STACK(0, 1); 1326 1327 cell = fw->param; 1328 tempIP = (ficlIp)((*cell).p); 1329 (++dataTop)->p = (cell + 1); 1330 (++returnTop)->p = (void *)ip; 1331 ip = (ficlInstruction *)tempIP; 1332 continue; 1333 } 1334 1335 #if FICL_WANT_FLOAT 1336 case ficlInstructionF2Fetch: 1337 CHECK_FLOAT_STACK(0, 2); 1338 CHECK_STACK(1, 0); 1339 FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); 1340 1341 case ficlInstructionFFetch: 1342 CHECK_FLOAT_STACK(0, 1); 1343 CHECK_STACK(1, 0); 1344 FLOAT_PUSH_CELL_POINTER((dataTop--)->p); 1345 1346 case ficlInstructionF2Store: 1347 CHECK_FLOAT_STACK(2, 0); 1348 CHECK_STACK(1, 0); 1349 FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p); 1350 1351 case ficlInstructionFStore: 1352 CHECK_FLOAT_STACK(1, 0); 1353 CHECK_STACK(1, 0); 1354 FLOAT_POP_CELL_POINTER((dataTop--)->p); 1355 #endif /* FICL_WANT_FLOAT */ 1356 1357 /* 1358 * two-fetch CORE ( a-addr -- x1 x2 ) 1359 * 1360 * Fetch the ficlCell pair x1 x2 stored at a-addr. 1361 * x2 is stored at a-addr and x1 at the next consecutive 1362 * ficlCell. It is equivalent to the sequence 1363 * DUP ficlCell+ @ SWAP @ . 1364 */ 1365 case ficlInstruction2Fetch: 1366 CHECK_STACK(1, 2); 1367 PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); 1368 1369 /* 1370 * fetch CORE ( a-addr -- x ) 1371 * 1372 * x is the value stored at a-addr. 1373 */ 1374 case ficlInstructionFetch: 1375 CHECK_STACK(1, 1); 1376 PUSH_CELL_POINTER((dataTop--)->p); 1377 1378 /* 1379 * two-store CORE ( x1 x2 a-addr -- ) 1380 * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr 1381 * and x1 at the next consecutive ficlCell. It is equivalent 1382 * to the sequence SWAP OVER ! ficlCell+ ! 1383 */ 1384 case ficlInstruction2Store: 1385 CHECK_STACK(3, 0); 1386 POP_CELL_POINTER_DOUBLE((dataTop--)->p); 1387 1388 /* 1389 * store CORE ( x a-addr -- ) 1390 * Store x at a-addr. 1391 */ 1392 case ficlInstructionStore: 1393 CHECK_STACK(2, 0); 1394 POP_CELL_POINTER((dataTop--)->p); 1395 1396 case ficlInstructionComma: { 1397 ficlDictionary *dictionary; 1398 CHECK_STACK(1, 0); 1399 1400 dictionary = ficlVmGetDictionary(vm); 1401 ficlDictionaryAppendCell(dictionary, *dataTop--); 1402 continue; 1403 } 1404 1405 case ficlInstructionCComma: { 1406 ficlDictionary *dictionary; 1407 char c; 1408 CHECK_STACK(1, 0); 1409 1410 dictionary = ficlVmGetDictionary(vm); 1411 c = (char)(dataTop--)->i; 1412 ficlDictionaryAppendCharacter(dictionary, c); 1413 continue; 1414 } 1415 1416 case ficlInstructionCells: 1417 CHECK_STACK(1, 1); 1418 dataTop->i *= sizeof (ficlCell); 1419 continue; 1420 1421 case ficlInstructionCellPlus: 1422 CHECK_STACK(1, 1); 1423 dataTop->i += sizeof (ficlCell); 1424 continue; 1425 1426 case ficlInstructionStar: 1427 CHECK_STACK(2, 1); 1428 i = (dataTop--)->i; 1429 dataTop->i *= i; 1430 continue; 1431 1432 case ficlInstructionNegate: 1433 CHECK_STACK(1, 1); 1434 dataTop->i = - dataTop->i; 1435 continue; 1436 1437 case ficlInstructionSlash: 1438 CHECK_STACK(2, 1); 1439 i = (dataTop--)->i; 1440 dataTop->i /= i; 1441 continue; 1442 1443 /* 1444 * slash-mod CORE ( n1 n2 -- n3 n4 ) 1445 * Divide n1 by n2, giving the single-ficlCell remainder n3 1446 * and the single-ficlCell quotient n4. An ambiguous condition 1447 * exists if n2 is zero. If n1 and n2 differ in sign, the 1448 * implementation-defined result returned will be the 1449 * same as that returned by either the phrase 1450 * >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM. 1451 * NOTE: Ficl complies with the second phrase 1452 * (symmetric division) 1453 */ 1454 case ficlInstructionSlashMod: { 1455 ficl2Integer n1; 1456 ficlInteger n2; 1457 ficl2IntegerQR qr; 1458 1459 CHECK_STACK(2, 2); 1460 n2 = dataTop[0].i; 1461 FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1); 1462 1463 qr = ficl2IntegerDivideSymmetric(n1, n2); 1464 dataTop[-1].i = qr.remainder; 1465 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); 1466 continue; 1467 } 1468 1469 case ficlInstruction2Star: 1470 CHECK_STACK(1, 1); 1471 dataTop->i <<= 1; 1472 continue; 1473 1474 case ficlInstruction2Slash: 1475 CHECK_STACK(1, 1); 1476 dataTop->i >>= 1; 1477 continue; 1478 1479 case ficlInstructionStarSlash: { 1480 ficlInteger x, y, z; 1481 ficl2Integer prod; 1482 CHECK_STACK(3, 1); 1483 1484 z = (dataTop--)->i; 1485 y = (dataTop--)->i; 1486 x = dataTop->i; 1487 1488 prod = ficl2IntegerMultiply(x, y); 1489 dataTop->i = FICL_2UNSIGNED_GET_LOW( 1490 ficl2IntegerDivideSymmetric(prod, z).quotient); 1491 continue; 1492 } 1493 1494 case ficlInstructionStarSlashMod: { 1495 ficlInteger x, y, z; 1496 ficl2Integer prod; 1497 ficl2IntegerQR qr; 1498 1499 CHECK_STACK(3, 2); 1500 1501 z = (dataTop--)->i; 1502 y = dataTop[0].i; 1503 x = dataTop[-1].i; 1504 1505 prod = ficl2IntegerMultiply(x, y); 1506 qr = ficl2IntegerDivideSymmetric(prod, z); 1507 1508 dataTop[-1].i = qr.remainder; 1509 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); 1510 continue; 1511 } 1512 1513 #if FICL_WANT_FLOAT 1514 case ficlInstructionF0: 1515 CHECK_FLOAT_STACK(0, 1); 1516 (++floatTop)->f = 0.0f; 1517 continue; 1518 1519 case ficlInstructionF1: 1520 CHECK_FLOAT_STACK(0, 1); 1521 (++floatTop)->f = 1.0f; 1522 continue; 1523 1524 case ficlInstructionFNeg1: 1525 CHECK_FLOAT_STACK(0, 1); 1526 (++floatTop)->f = -1.0f; 1527 continue; 1528 1529 /* 1530 * Floating point literal execution word. 1531 */ 1532 case ficlInstructionFLiteralParen: 1533 CHECK_FLOAT_STACK(0, 1); 1534 1535 /* 1536 * Yes, I'm using ->i here, 1537 * but it's really a float. --lch 1538 */ 1539 (++floatTop)->i = *ip++; 1540 continue; 1541 1542 /* 1543 * Do float addition r1 + r2. 1544 * f+ ( r1 r2 -- r ) 1545 */ 1546 case ficlInstructionFPlus: 1547 CHECK_FLOAT_STACK(2, 1); 1548 1549 f = (floatTop--)->f; 1550 floatTop->f += f; 1551 continue; 1552 1553 /* 1554 * Do float subtraction r1 - r2. 1555 * f- ( r1 r2 -- r ) 1556 */ 1557 case ficlInstructionFMinus: 1558 CHECK_FLOAT_STACK(2, 1); 1559 1560 f = (floatTop--)->f; 1561 floatTop->f -= f; 1562 continue; 1563 1564 /* 1565 * Do float multiplication r1 * r2. 1566 * f* ( r1 r2 -- r ) 1567 */ 1568 case ficlInstructionFStar: 1569 CHECK_FLOAT_STACK(2, 1); 1570 1571 f = (floatTop--)->f; 1572 floatTop->f *= f; 1573 continue; 1574 1575 /* 1576 * Do float negation. 1577 * fnegate ( r -- r ) 1578 */ 1579 case ficlInstructionFNegate: 1580 CHECK_FLOAT_STACK(1, 1); 1581 1582 floatTop->f = -(floatTop->f); 1583 continue; 1584 1585 /* 1586 * Do float division r1 / r2. 1587 * f/ ( r1 r2 -- r ) 1588 */ 1589 case ficlInstructionFSlash: 1590 CHECK_FLOAT_STACK(2, 1); 1591 1592 f = (floatTop--)->f; 1593 floatTop->f /= f; 1594 continue; 1595 1596 /* 1597 * Do float + integer r + n. 1598 * f+i ( r n -- r ) 1599 */ 1600 case ficlInstructionFPlusI: 1601 CHECK_FLOAT_STACK(1, 1); 1602 CHECK_STACK(1, 0); 1603 1604 f = (ficlFloat)(dataTop--)->f; 1605 floatTop->f += f; 1606 continue; 1607 1608 /* 1609 * Do float - integer r - n. 1610 * f-i ( r n -- r ) 1611 */ 1612 case ficlInstructionFMinusI: 1613 CHECK_FLOAT_STACK(1, 1); 1614 CHECK_STACK(1, 0); 1615 1616 f = (ficlFloat)(dataTop--)->f; 1617 floatTop->f -= f; 1618 continue; 1619 1620 /* 1621 * Do float * integer r * n. 1622 * f*i ( r n -- r ) 1623 */ 1624 case ficlInstructionFStarI: 1625 CHECK_FLOAT_STACK(1, 1); 1626 CHECK_STACK(1, 0); 1627 1628 f = (ficlFloat)(dataTop--)->f; 1629 floatTop->f *= f; 1630 continue; 1631 1632 /* 1633 * Do float / integer r / n. 1634 * f/i ( r n -- r ) 1635 */ 1636 case ficlInstructionFSlashI: 1637 CHECK_FLOAT_STACK(1, 1); 1638 CHECK_STACK(1, 0); 1639 1640 f = (ficlFloat)(dataTop--)->f; 1641 floatTop->f /= f; 1642 continue; 1643 1644 /* 1645 * Do integer - float n - r. 1646 * i-f ( n r -- r ) 1647 */ 1648 case ficlInstructionIMinusF: 1649 CHECK_FLOAT_STACK(1, 1); 1650 CHECK_STACK(1, 0); 1651 1652 f = (ficlFloat)(dataTop--)->f; 1653 floatTop->f = f - floatTop->f; 1654 continue; 1655 1656 /* 1657 * Do integer / float n / r. 1658 * i/f ( n r -- r ) 1659 */ 1660 case ficlInstructionISlashF: 1661 CHECK_FLOAT_STACK(1, 1); 1662 CHECK_STACK(1, 0); 1663 1664 f = (ficlFloat)(dataTop--)->f; 1665 floatTop->f = f / floatTop->f; 1666 continue; 1667 1668 /* 1669 * Do integer to float conversion. 1670 * int>float ( n -- r ) 1671 */ 1672 case ficlInstructionIntToFloat: 1673 CHECK_STACK(1, 0); 1674 CHECK_FLOAT_STACK(0, 1); 1675 1676 (++floatTop)->f = ((dataTop--)->f); 1677 continue; 1678 1679 /* 1680 * Do float to integer conversion. 1681 * float>int ( r -- n ) 1682 */ 1683 case ficlInstructionFloatToInt: 1684 CHECK_STACK(0, 1); 1685 CHECK_FLOAT_STACK(1, 0); 1686 1687 (++dataTop)->i = ((floatTop--)->i); 1688 continue; 1689 1690 /* 1691 * Add a floating point number to contents of a variable. 1692 * f+! ( r n -- ) 1693 */ 1694 case ficlInstructionFPlusStore: { 1695 ficlCell *cell; 1696 1697 CHECK_STACK(1, 0); 1698 CHECK_FLOAT_STACK(1, 0); 1699 1700 cell = (ficlCell *)(dataTop--)->p; 1701 cell->f += (floatTop--)->f; 1702 continue; 1703 } 1704 1705 /* 1706 * Do float stack drop. 1707 * fdrop ( r -- ) 1708 */ 1709 case ficlInstructionFDrop: 1710 CHECK_FLOAT_STACK(1, 0); 1711 floatTop--; 1712 continue; 1713 1714 /* 1715 * Do float stack ?dup. 1716 * f?dup ( r -- r ) 1717 */ 1718 case ficlInstructionFQuestionDup: 1719 CHECK_FLOAT_STACK(1, 2); 1720 1721 if (floatTop->f != 0) 1722 goto FDUP; 1723 1724 continue; 1725 1726 /* 1727 * Do float stack dup. 1728 * fdup ( r -- r r ) 1729 */ 1730 case ficlInstructionFDup: 1731 CHECK_FLOAT_STACK(1, 2); 1732 1733 FDUP: 1734 floatTop[1] = floatTop[0]; 1735 floatTop++; 1736 continue; 1737 1738 /* 1739 * Do float stack swap. 1740 * fswap ( r1 r2 -- r2 r1 ) 1741 */ 1742 case ficlInstructionFSwap: 1743 CHECK_FLOAT_STACK(2, 2); 1744 1745 c = floatTop[0]; 1746 floatTop[0] = floatTop[-1]; 1747 floatTop[-1] = c; 1748 continue; 1749 1750 /* 1751 * Do float stack 2drop. 1752 * f2drop ( r r -- ) 1753 */ 1754 case ficlInstructionF2Drop: 1755 CHECK_FLOAT_STACK(2, 0); 1756 1757 floatTop -= 2; 1758 continue; 1759 1760 /* 1761 * Do float stack 2dup. 1762 * f2dup ( r1 r2 -- r1 r2 r1 r2 ) 1763 */ 1764 case ficlInstructionF2Dup: 1765 CHECK_FLOAT_STACK(2, 4); 1766 1767 floatTop[1] = floatTop[-1]; 1768 floatTop[2] = *floatTop; 1769 floatTop += 2; 1770 continue; 1771 1772 /* 1773 * Do float stack over. 1774 * fover ( r1 r2 -- r1 r2 r1 ) 1775 */ 1776 case ficlInstructionFOver: 1777 CHECK_FLOAT_STACK(2, 3); 1778 1779 floatTop[1] = floatTop[-1]; 1780 floatTop++; 1781 continue; 1782 1783 /* 1784 * Do float stack 2over. 1785 * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 ) 1786 */ 1787 case ficlInstructionF2Over: 1788 CHECK_FLOAT_STACK(4, 6); 1789 1790 floatTop[1] = floatTop[-2]; 1791 floatTop[2] = floatTop[-1]; 1792 floatTop += 2; 1793 continue; 1794 1795 /* 1796 * Do float stack pick. 1797 * fpick ( n -- r ) 1798 */ 1799 case ficlInstructionFPick: 1800 CHECK_STACK(1, 0); 1801 c = *dataTop--; 1802 CHECK_FLOAT_STACK(c.i+2, c.i+3); 1803 1804 floatTop[1] = floatTop[- c.i - 1]; 1805 continue; 1806 1807 /* 1808 * Do float stack rot. 1809 * frot ( r1 r2 r3 -- r2 r3 r1 ) 1810 */ 1811 case ficlInstructionFRot: 1812 i = 2; 1813 goto FROLL; 1814 1815 /* 1816 * Do float stack roll. 1817 * froll ( n -- ) 1818 */ 1819 case ficlInstructionFRoll: 1820 CHECK_STACK(1, 0); 1821 i = (dataTop--)->i; 1822 1823 if (i < 1) 1824 continue; 1825 1826 FROLL: 1827 CHECK_FLOAT_STACK(i+1, i+2); 1828 c = floatTop[-i]; 1829 memmove(floatTop - i, floatTop - (i - 1), 1830 i * sizeof (ficlCell)); 1831 *floatTop = c; 1832 1833 continue; 1834 1835 /* 1836 * Do float stack -rot. 1837 * f-rot ( r1 r2 r3 -- r3 r1 r2 ) 1838 */ 1839 case ficlInstructionFMinusRot: 1840 i = 2; 1841 goto FMINUSROLL; 1842 1843 1844 /* 1845 * Do float stack -roll. 1846 * f-roll ( n -- ) 1847 */ 1848 case ficlInstructionFMinusRoll: 1849 CHECK_STACK(1, 0); 1850 i = (dataTop--)->i; 1851 1852 if (i < 1) 1853 continue; 1854 1855 FMINUSROLL: 1856 CHECK_FLOAT_STACK(i+1, i+2); 1857 c = *floatTop; 1858 memmove(floatTop - (i - 1), floatTop - i, 1859 i * sizeof (ficlCell)); 1860 floatTop[-i] = c; 1861 1862 continue; 1863 1864 /* 1865 * Do float stack 2swap 1866 * f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 ) 1867 */ 1868 case ficlInstructionF2Swap: { 1869 ficlCell c2; 1870 CHECK_FLOAT_STACK(4, 4); 1871 1872 c = *floatTop; 1873 c2 = floatTop[-1]; 1874 1875 *floatTop = floatTop[-2]; 1876 floatTop[-1] = floatTop[-3]; 1877 1878 floatTop[-2] = c; 1879 floatTop[-3] = c2; 1880 continue; 1881 } 1882 1883 /* 1884 * Do float 0= comparison r = 0.0. 1885 * f0= ( r -- T/F ) 1886 */ 1887 case ficlInstructionF0Equals: 1888 CHECK_FLOAT_STACK(1, 0); 1889 CHECK_STACK(0, 1); 1890 1891 (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f); 1892 continue; 1893 1894 /* 1895 * Do float 0< comparison r < 0.0. 1896 * f0< ( r -- T/F ) 1897 */ 1898 case ficlInstructionF0Less: 1899 CHECK_FLOAT_STACK(1, 0); 1900 CHECK_STACK(0, 1); 1901 1902 (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f); 1903 continue; 1904 1905 /* 1906 * Do float 0> comparison r > 0.0. 1907 * f0> ( r -- T/F ) 1908 */ 1909 case ficlInstructionF0Greater: 1910 CHECK_FLOAT_STACK(1, 0); 1911 CHECK_STACK(0, 1); 1912 1913 (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f); 1914 continue; 1915 1916 /* 1917 * Do float = comparison r1 = r2. 1918 * f= ( r1 r2 -- T/F ) 1919 */ 1920 case ficlInstructionFEquals: 1921 CHECK_FLOAT_STACK(2, 0); 1922 CHECK_STACK(0, 1); 1923 1924 f = (floatTop--)->f; 1925 (++dataTop)->i = FICL_BOOL((floatTop--)->f == f); 1926 continue; 1927 1928 /* 1929 * Do float < comparison r1 < r2. 1930 * f< ( r1 r2 -- T/F ) 1931 */ 1932 case ficlInstructionFLess: 1933 CHECK_FLOAT_STACK(2, 0); 1934 CHECK_STACK(0, 1); 1935 1936 f = (floatTop--)->f; 1937 (++dataTop)->i = FICL_BOOL((floatTop--)->f < f); 1938 continue; 1939 1940 /* 1941 * Do float > comparison r1 > r2. 1942 * f> ( r1 r2 -- T/F ) 1943 */ 1944 case ficlInstructionFGreater: 1945 CHECK_FLOAT_STACK(2, 0); 1946 CHECK_STACK(0, 1); 1947 1948 f = (floatTop--)->f; 1949 (++dataTop)->i = FICL_BOOL((floatTop--)->f > f); 1950 continue; 1951 1952 1953 /* 1954 * Move float to param stack (assumes they both fit in a 1955 * single ficlCell) f>s 1956 */ 1957 case ficlInstructionFFrom: 1958 CHECK_FLOAT_STACK(1, 0); 1959 CHECK_STACK(0, 1); 1960 1961 *++dataTop = *floatTop--; 1962 continue; 1963 1964 case ficlInstructionToF: 1965 CHECK_FLOAT_STACK(0, 1); 1966 CHECK_STACK(1, 0); 1967 1968 *++floatTop = *dataTop--; 1969 continue; 1970 1971 #endif /* FICL_WANT_FLOAT */ 1972 1973 /* 1974 * c o l o n P a r e n 1975 * This is the code that executes a colon definition. It 1976 * assumes that the virtual machine is running a "next" loop 1977 * (See the vm.c for its implementation of member function 1978 * vmExecute()). The colon code simply copies the address of 1979 * the first word in the list of words to interpret into IP 1980 * after saving its old value. When we return to the "next" 1981 * loop, the virtual machine will call the code for each 1982 * word in turn. 1983 */ 1984 case ficlInstructionColonParen: 1985 (++returnTop)->p = (void *)ip; 1986 ip = (ficlInstruction *)(fw->param); 1987 continue; 1988 1989 case ficlInstructionCreateParen: 1990 CHECK_STACK(0, 1); 1991 (++dataTop)->p = (fw->param + 1); 1992 continue; 1993 1994 case ficlInstructionVariableParen: 1995 CHECK_STACK(0, 1); 1996 (++dataTop)->p = fw->param; 1997 continue; 1998 1999 /* 2000 * c o n s t a n t P a r e n 2001 * This is the run-time code for "constant". It simply returns 2002 * the contents of its word's first data ficlCell. 2003 */ 2004 2005 #if FICL_WANT_FLOAT 2006 case ficlInstructionF2ConstantParen: 2007 CHECK_FLOAT_STACK(0, 2); 2008 FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param); 2009 2010 case ficlInstructionFConstantParen: 2011 CHECK_FLOAT_STACK(0, 1); 2012 FLOAT_PUSH_CELL_POINTER(fw->param); 2013 #endif /* FICL_WANT_FLOAT */ 2014 2015 case ficlInstruction2ConstantParen: 2016 CHECK_STACK(0, 2); 2017 PUSH_CELL_POINTER_DOUBLE(fw->param); 2018 2019 case ficlInstructionConstantParen: 2020 CHECK_STACK(0, 1); 2021 PUSH_CELL_POINTER(fw->param); 2022 2023 #if FICL_WANT_USER 2024 case ficlInstructionUserParen: { 2025 ficlInteger i = fw->param[0].i; 2026 (++dataTop)->p = &vm->user[i]; 2027 continue; 2028 } 2029 #endif 2030 2031 default: 2032 /* 2033 * Clever hack, or evil coding? You be the judge. 2034 * 2035 * If the word we've been asked to execute is in fact 2036 * an *instruction*, we grab the instruction, stow it 2037 * in "i" (our local cache of *ip), and *jump* to the 2038 * top of the switch statement. --lch 2039 */ 2040 if (((ficlInstruction)fw->code > 2041 ficlInstructionInvalid) && 2042 ((ficlInstruction)fw->code < ficlInstructionLast)) { 2043 instruction = (ficlInstruction)fw->code; 2044 goto AGAIN; 2045 } 2046 2047 LOCAL_VARIABLE_SPILL; 2048 (vm)->runningWord = fw; 2049 fw->code(vm); 2050 LOCAL_VARIABLE_REFILL; 2051 continue; 2052 } 2053 } 2054 2055 LOCAL_VARIABLE_SPILL; 2056 vm->exceptionHandler = oldExceptionHandler; 2057 } 2058 2059 /* 2060 * v m G e t D i c t 2061 * Returns the address dictionary for this VM's system 2062 */ 2063 ficlDictionary * 2064 ficlVmGetDictionary(ficlVm *vm) 2065 { 2066 FICL_VM_ASSERT(vm, vm); 2067 return (vm->callback.system->dictionary); 2068 } 2069 2070 /* 2071 * v m G e t S t r i n g 2072 * Parses a string out of the VM input buffer and copies up to the first 2073 * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a 2074 * ficlCountedString. The destination string is NULL terminated. 2075 * 2076 * Returns the address of the first unused character in the dest buffer. 2077 */ 2078 char * 2079 ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter) 2080 { 2081 ficlString s = ficlVmParseStringEx(vm, delimiter, 0); 2082 2083 if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) { 2084 FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX); 2085 } 2086 2087 (void) strncpy(counted->text, FICL_STRING_GET_POINTER(s), 2088 FICL_STRING_GET_LENGTH(s)); 2089 counted->text[FICL_STRING_GET_LENGTH(s)] = '\0'; 2090 counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); 2091 2092 return (counted->text + FICL_STRING_GET_LENGTH(s) + 1); 2093 } 2094 2095 /* 2096 * v m G e t W o r d 2097 * vmGetWord calls vmGetWord0 repeatedly until it gets a string with 2098 * non-zero length. 2099 */ 2100 ficlString 2101 ficlVmGetWord(ficlVm *vm) 2102 { 2103 ficlString s = ficlVmGetWord0(vm); 2104 2105 if (FICL_STRING_GET_LENGTH(s) == 0) { 2106 ficlVmThrow(vm, FICL_VM_STATUS_RESTART); 2107 } 2108 2109 return (s); 2110 } 2111 2112 /* 2113 * v m G e t W o r d 0 2114 * Skip leading whitespace and parse a space delimited word from the tib. 2115 * Returns the start address and length of the word. Updates the tib 2116 * to reflect characters consumed, including the trailing delimiter. 2117 * If there's nothing of interest in the tib, returns zero. This function 2118 * does not use vmParseString because it uses isspace() rather than a 2119 * single delimiter character. 2120 */ 2121 ficlString 2122 ficlVmGetWord0(ficlVm *vm) 2123 { 2124 char *trace = ficlVmGetInBuf(vm); 2125 char *stop = ficlVmGetInBufEnd(vm); 2126 ficlString s; 2127 ficlUnsigned length = 0; 2128 char c = 0; 2129 2130 trace = ficlStringSkipSpace(trace, stop); 2131 FICL_STRING_SET_POINTER(s, trace); 2132 2133 /* Please leave this loop this way; it makes Purify happier. --lch */ 2134 for (;;) { 2135 if (trace == stop) 2136 break; 2137 c = *trace; 2138 if (isspace((unsigned char)c)) 2139 break; 2140 length++; 2141 trace++; 2142 } 2143 2144 FICL_STRING_SET_LENGTH(s, length); 2145 2146 /* skip one trailing delimiter */ 2147 if ((trace != stop) && isspace((unsigned char)c)) 2148 trace++; 2149 2150 ficlVmUpdateTib(vm, trace); 2151 2152 return (s); 2153 } 2154 2155 /* 2156 * v m G e t W o r d T o P a d 2157 * Does vmGetWord and copies the result to the pad as a NULL terminated 2158 * string. Returns the length of the string. If the string is too long 2159 * to fit in the pad, it is truncated. 2160 */ 2161 int 2162 ficlVmGetWordToPad(ficlVm *vm) 2163 { 2164 ficlString s; 2165 char *pad = (char *)vm->pad; 2166 s = ficlVmGetWord(vm); 2167 2168 if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE) 2169 FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE); 2170 2171 (void) strncpy(pad, FICL_STRING_GET_POINTER(s), 2172 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 (void) vsprintf(vm->pad, fmt, list); 2361 va_end(list); 2362 (void) 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 (void) 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 (void) 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