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 case ficlInstructionUGreaterThan: 1128 CHECK_STACK(2, 1); 1129 u = (dataTop--)->u; 1130 dataTop->i = FICL_BOOL(dataTop->u > u); 1131 continue; 1132 1133 } 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 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 strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s)); 2172 pad[FICL_STRING_GET_LENGTH(s)] = '\0'; 2173 return ((int)(FICL_STRING_GET_LENGTH(s))); 2174 } 2175 2176 /* 2177 * v m P a r s e S t r i n g 2178 * Parses a string out of the input buffer using the delimiter 2179 * specified. Skips leading delimiters, marks the start of the string, 2180 * and counts characters to the next delimiter it encounters. It then 2181 * updates the vm input buffer to consume all these chars, including the 2182 * trailing delimiter. 2183 * Returns the address and length of the parsed string, not including the 2184 * trailing delimiter. 2185 */ 2186 ficlString 2187 ficlVmParseString(ficlVm *vm, char delimiter) 2188 { 2189 return (ficlVmParseStringEx(vm, delimiter, 1)); 2190 } 2191 2192 ficlString 2193 ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters) 2194 { 2195 ficlString s; 2196 char *trace = ficlVmGetInBuf(vm); 2197 char *stop = ficlVmGetInBufEnd(vm); 2198 char c; 2199 2200 if (skipLeadingDelimiters) { 2201 while ((trace != stop) && (*trace == delimiter)) 2202 trace++; 2203 } 2204 2205 FICL_STRING_SET_POINTER(s, trace); /* mark start of text */ 2206 2207 /* find next delimiter or end of line */ 2208 for (c = *trace; 2209 (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n'); 2210 c = *++trace) { 2211 ; 2212 } 2213 2214 /* set length of result */ 2215 FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s)); 2216 2217 /* gobble trailing delimiter */ 2218 if ((trace != stop) && (*trace == delimiter)) 2219 trace++; 2220 2221 ficlVmUpdateTib(vm, trace); 2222 return (s); 2223 } 2224 2225 2226 /* 2227 * v m P o p 2228 */ 2229 ficlCell 2230 ficlVmPop(ficlVm *vm) 2231 { 2232 return (ficlStackPop(vm->dataStack)); 2233 } 2234 2235 /* 2236 * v m P u s h 2237 */ 2238 void 2239 ficlVmPush(ficlVm *vm, ficlCell c) 2240 { 2241 ficlStackPush(vm->dataStack, c); 2242 } 2243 2244 /* 2245 * v m P o p I P 2246 */ 2247 void 2248 ficlVmPopIP(ficlVm *vm) 2249 { 2250 vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack)); 2251 } 2252 2253 /* 2254 * v m P u s h I P 2255 */ 2256 void 2257 ficlVmPushIP(ficlVm *vm, ficlIp newIP) 2258 { 2259 ficlStackPushPointer(vm->returnStack, (void *)vm->ip); 2260 vm->ip = newIP; 2261 } 2262 2263 /* 2264 * v m P u s h T i b 2265 * Binds the specified input string to the VM and clears >IN (the index) 2266 */ 2267 void 2268 ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib) 2269 { 2270 if (pSaveTib) { 2271 *pSaveTib = vm->tib; 2272 } 2273 vm->tib.text = text; 2274 vm->tib.end = text + nChars; 2275 vm->tib.index = 0; 2276 } 2277 2278 void 2279 ficlVmPopTib(ficlVm *vm, ficlTIB *pTib) 2280 { 2281 if (pTib) { 2282 vm->tib = *pTib; 2283 } 2284 } 2285 2286 /* 2287 * v m Q u i t 2288 */ 2289 void 2290 ficlVmQuit(ficlVm *vm) 2291 { 2292 ficlStackReset(vm->returnStack); 2293 vm->restart = 0; 2294 vm->ip = NULL; 2295 vm->runningWord = NULL; 2296 vm->state = FICL_VM_STATE_INTERPRET; 2297 vm->tib.text = NULL; 2298 vm->tib.end = NULL; 2299 vm->tib.index = 0; 2300 vm->pad[0] = '\0'; 2301 vm->sourceId.i = 0; 2302 } 2303 2304 /* 2305 * v m R e s e t 2306 */ 2307 void 2308 ficlVmReset(ficlVm *vm) 2309 { 2310 ficlVmQuit(vm); 2311 ficlStackReset(vm->dataStack); 2312 #if FICL_WANT_FLOAT 2313 ficlStackReset(vm->floatStack); 2314 #endif 2315 vm->base = 10; 2316 } 2317 2318 /* 2319 * v m S e t T e x t O u t 2320 * Binds the specified output callback to the vm. If you pass NULL, 2321 * binds the default output function (ficlTextOut) 2322 */ 2323 void 2324 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut) 2325 { 2326 vm->callback.textOut = textOut; 2327 } 2328 2329 void 2330 ficlVmTextOut(ficlVm *vm, char *text) 2331 { 2332 ficlCallbackTextOut((ficlCallback *)vm, text); 2333 } 2334 2335 2336 void 2337 ficlVmErrorOut(ficlVm *vm, char *text) 2338 { 2339 ficlCallbackErrorOut((ficlCallback *)vm, text); 2340 } 2341 2342 2343 /* 2344 * v m T h r o w 2345 */ 2346 void 2347 ficlVmThrow(ficlVm *vm, int except) 2348 { 2349 if (vm->exceptionHandler) 2350 longjmp(*(vm->exceptionHandler), except); 2351 } 2352 2353 void 2354 ficlVmThrowError(ficlVm *vm, char *fmt, ...) 2355 { 2356 va_list list; 2357 2358 va_start(list, fmt); 2359 vsprintf(vm->pad, fmt, list); 2360 va_end(list); 2361 strcat(vm->pad, "\n"); 2362 2363 ficlVmErrorOut(vm, vm->pad); 2364 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); 2365 } 2366 2367 void 2368 ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list) 2369 { 2370 vsprintf(vm->pad, fmt, list); 2371 /* 2372 * well, we can try anyway, we're certainly not 2373 * returning to our caller! 2374 */ 2375 va_end(list); 2376 strcat(vm->pad, "\n"); 2377 2378 ficlVmErrorOut(vm, vm->pad); 2379 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); 2380 } 2381 2382 /* 2383 * f i c l E v a l u a t e 2384 * Wrapper for ficlExec() which sets SOURCE-ID to -1. 2385 */ 2386 int 2387 ficlVmEvaluate(ficlVm *vm, char *s) 2388 { 2389 int returnValue; 2390 ficlCell id = vm->sourceId; 2391 ficlString string; 2392 vm->sourceId.i = -1; 2393 FICL_STRING_SET_FROM_CSTRING(string, s); 2394 returnValue = ficlVmExecuteString(vm, string); 2395 vm->sourceId = id; 2396 return (returnValue); 2397 } 2398 2399 /* 2400 * f i c l E x e c 2401 * Evaluates a block of input text in the context of the 2402 * specified interpreter. Emits any requested output to the 2403 * interpreter's output function. 2404 * 2405 * Contains the "inner interpreter" code in a tight loop 2406 * 2407 * Returns one of the VM_XXXX codes defined in ficl.h: 2408 * VM_OUTOFTEXT is the normal exit condition 2409 * VM_ERREXIT means that the interpreter encountered a syntax error 2410 * and the vm has been reset to recover (some or all 2411 * of the text block got ignored 2412 * VM_USEREXIT means that the user executed the "bye" command 2413 * to shut down the interpreter. This would be a good 2414 * time to delete the vm, etc -- or you can ignore this 2415 * signal. 2416 */ 2417 int 2418 ficlVmExecuteString(ficlVm *vm, ficlString s) 2419 { 2420 ficlSystem *system = vm->callback.system; 2421 ficlDictionary *dictionary = system->dictionary; 2422 2423 int except; 2424 jmp_buf vmState; 2425 jmp_buf *oldState; 2426 ficlTIB saveficlTIB; 2427 2428 FICL_VM_ASSERT(vm, vm); 2429 FICL_VM_ASSERT(vm, system->interpreterLoop[0]); 2430 2431 ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s), 2432 FICL_STRING_GET_LENGTH(s), &saveficlTIB); 2433 2434 /* 2435 * Save and restore VM's jmp_buf to enable nested calls to ficlExec 2436 */ 2437 oldState = vm->exceptionHandler; 2438 2439 /* This has to come before the setjmp! */ 2440 vm->exceptionHandler = &vmState; 2441 except = setjmp(vmState); 2442 2443 switch (except) { 2444 case 0: 2445 if (vm->restart) { 2446 vm->runningWord->code(vm); 2447 vm->restart = 0; 2448 } else { /* set VM up to interpret text */ 2449 ficlVmPushIP(vm, &(system->interpreterLoop[0])); 2450 } 2451 2452 ficlVmInnerLoop(vm, 0); 2453 break; 2454 2455 case FICL_VM_STATUS_RESTART: 2456 vm->restart = 1; 2457 except = FICL_VM_STATUS_OUT_OF_TEXT; 2458 break; 2459 2460 case FICL_VM_STATUS_OUT_OF_TEXT: 2461 ficlVmPopIP(vm); 2462 #if 0 /* we dont output prompt in loader */ 2463 if ((vm->state != FICL_VM_STATE_COMPILE) && 2464 (vm->sourceId.i == 0)) 2465 ficlVmTextOut(vm, FICL_PROMPT); 2466 #endif 2467 break; 2468 2469 case FICL_VM_STATUS_USER_EXIT: 2470 case FICL_VM_STATUS_INNER_EXIT: 2471 case FICL_VM_STATUS_BREAK: 2472 break; 2473 2474 case FICL_VM_STATUS_QUIT: 2475 if (vm->state == FICL_VM_STATE_COMPILE) { 2476 ficlDictionaryAbortDefinition(dictionary); 2477 #if FICL_WANT_LOCALS 2478 ficlDictionaryEmpty(system->locals, 2479 system->locals->forthWordlist->size); 2480 #endif 2481 } 2482 ficlVmQuit(vm); 2483 break; 2484 2485 case FICL_VM_STATUS_ERROR_EXIT: 2486 case FICL_VM_STATUS_ABORT: 2487 case FICL_VM_STATUS_ABORTQ: 2488 default: /* user defined exit code?? */ 2489 if (vm->state == FICL_VM_STATE_COMPILE) { 2490 ficlDictionaryAbortDefinition(dictionary); 2491 #if FICL_WANT_LOCALS 2492 ficlDictionaryEmpty(system->locals, 2493 system->locals->forthWordlist->size); 2494 #endif 2495 } 2496 ficlDictionaryResetSearchOrder(dictionary); 2497 ficlVmReset(vm); 2498 break; 2499 } 2500 2501 vm->exceptionHandler = oldState; 2502 ficlVmPopTib(vm, &saveficlTIB); 2503 return (except); 2504 } 2505 2506 /* 2507 * f i c l E x e c X T 2508 * Given a pointer to a ficlWord, push an inner interpreter and 2509 * execute the word to completion. This is in contrast with vmExecute, 2510 * which does not guarantee that the word will have completed when 2511 * the function returns (ie in the case of colon definitions, which 2512 * need an inner interpreter to finish) 2513 * 2514 * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal 2515 * exit condition is VM_INNEREXIT, Ficl's private signal to exit the 2516 * inner loop under normal circumstances. If another code is thrown to 2517 * exit the loop, this function will re-throw it if it's nested under 2518 * itself or ficlExec. 2519 * 2520 * NOTE: this function is intended so that C code can execute ficlWords 2521 * given their address in the dictionary (xt). 2522 */ 2523 int 2524 ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord) 2525 { 2526 int except; 2527 jmp_buf vmState; 2528 jmp_buf *oldState; 2529 ficlWord *oldRunningWord; 2530 2531 FICL_VM_ASSERT(vm, vm); 2532 FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord); 2533 2534 /* 2535 * Save the runningword so that RESTART behaves correctly 2536 * over nested calls. 2537 */ 2538 oldRunningWord = vm->runningWord; 2539 /* 2540 * Save and restore VM's jmp_buf to enable nested calls 2541 */ 2542 oldState = vm->exceptionHandler; 2543 /* This has to come before the setjmp! */ 2544 vm->exceptionHandler = &vmState; 2545 except = setjmp(vmState); 2546 2547 if (except) 2548 ficlVmPopIP(vm); 2549 else 2550 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); 2551 2552 switch (except) { 2553 case 0: 2554 ficlVmExecuteWord(vm, pWord); 2555 ficlVmInnerLoop(vm, 0); 2556 break; 2557 2558 case FICL_VM_STATUS_INNER_EXIT: 2559 case FICL_VM_STATUS_BREAK: 2560 break; 2561 2562 case FICL_VM_STATUS_RESTART: 2563 case FICL_VM_STATUS_OUT_OF_TEXT: 2564 case FICL_VM_STATUS_USER_EXIT: 2565 case FICL_VM_STATUS_QUIT: 2566 case FICL_VM_STATUS_ERROR_EXIT: 2567 case FICL_VM_STATUS_ABORT: 2568 case FICL_VM_STATUS_ABORTQ: 2569 default: /* user defined exit code?? */ 2570 if (oldState) { 2571 vm->exceptionHandler = oldState; 2572 ficlVmThrow(vm, except); 2573 } 2574 break; 2575 } 2576 2577 vm->exceptionHandler = oldState; 2578 vm->runningWord = oldRunningWord; 2579 return (except); 2580 } 2581 2582 /* 2583 * f i c l P a r s e N u m b e r 2584 * Attempts to convert the NULL terminated string in the VM's pad to 2585 * a number using the VM's current base. If successful, pushes the number 2586 * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE. 2587 * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See 2588 * the standard for DOUBLE wordset. 2589 */ 2590 int 2591 ficlVmParseNumber(ficlVm *vm, ficlString s) 2592 { 2593 ficlInteger accumulator = 0; 2594 char isNegative = 0; 2595 char isDouble = 0; 2596 unsigned base = vm->base; 2597 char *trace = FICL_STRING_GET_POINTER(s); 2598 ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); 2599 unsigned c; 2600 unsigned digit; 2601 2602 if (length > 1) { 2603 switch (*trace) { 2604 case '-': 2605 trace++; 2606 length--; 2607 isNegative = 1; 2608 break; 2609 case '+': 2610 trace++; 2611 length--; 2612 isNegative = 0; 2613 break; 2614 default: 2615 break; 2616 } 2617 } 2618 2619 /* detect & remove trailing decimal */ 2620 if ((length > 0) && (trace[length - 1] == '.')) { 2621 isDouble = 1; 2622 length--; 2623 } 2624 2625 if (length == 0) /* detect "+", "-", ".", "+." etc */ 2626 return (0); /* false */ 2627 2628 while ((length--) && ((c = *trace++) != '\0')) { 2629 if (!isalnum(c)) 2630 return (0); /* false */ 2631 2632 digit = c - '0'; 2633 2634 if (digit > 9) 2635 digit = tolower(c) - 'a' + 10; 2636 2637 if (digit >= base) 2638 return (0); /* false */ 2639 2640 accumulator = accumulator * base + digit; 2641 } 2642 2643 if (isNegative) 2644 accumulator = -accumulator; 2645 2646 ficlStackPushInteger(vm->dataStack, accumulator); 2647 if (vm->state == FICL_VM_STATE_COMPILE) 2648 ficlPrimitiveLiteralIm(vm); 2649 2650 if (isDouble) { /* simple (required) DOUBLE support */ 2651 if (isNegative) 2652 ficlStackPushInteger(vm->dataStack, -1); 2653 else 2654 ficlStackPushInteger(vm->dataStack, 0); 2655 if (vm->state == FICL_VM_STATE_COMPILE) 2656 ficlPrimitiveLiteralIm(vm); 2657 } 2658 2659 return (1); /* true */ 2660 } 2661 2662 /* 2663 * d i c t C h e c k 2664 * Checks the dictionary for corruption and throws appropriate 2665 * errors. 2666 * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot 2667 * -n number of ADDRESS UNITS proposed to de-allot 2668 * 0 just do a consistency check 2669 */ 2670 void 2671 ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) 2672 { 2673 #if FICL_ROBUST >= 1 2674 if ((cells >= 0) && 2675 (ficlDictionaryCellsAvailable(dictionary) * 2676 (int)sizeof (ficlCell) < cells)) { 2677 ficlVmThrowError(vm, "Error: dictionary full"); 2678 } 2679 2680 if ((cells <= 0) && 2681 (ficlDictionaryCellsUsed(dictionary) * 2682 (int)sizeof (ficlCell) < -cells)) { 2683 ficlVmThrowError(vm, "Error: dictionary underflow"); 2684 } 2685 #else /* FICL_ROBUST >= 1 */ 2686 FICL_IGNORE(vm); 2687 FICL_IGNORE(dictionary); 2688 FICL_IGNORE(cells); 2689 #endif /* FICL_ROBUST >= 1 */ 2690 } 2691 2692 void 2693 ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) 2694 { 2695 #if FICL_ROBUST >= 1 2696 ficlVmDictionarySimpleCheck(vm, dictionary, cells); 2697 2698 if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) { 2699 ficlDictionaryResetSearchOrder(dictionary); 2700 ficlVmThrowError(vm, "Error: search order overflow"); 2701 } else if (dictionary->wordlistCount < 0) { 2702 ficlDictionaryResetSearchOrder(dictionary); 2703 ficlVmThrowError(vm, "Error: search order underflow"); 2704 } 2705 #else /* FICL_ROBUST >= 1 */ 2706 FICL_IGNORE(vm); 2707 FICL_IGNORE(dictionary); 2708 FICL_IGNORE(cells); 2709 #endif /* FICL_ROBUST >= 1 */ 2710 } 2711 2712 void 2713 ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n) 2714 { 2715 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n); 2716 FICL_IGNORE(vm); 2717 ficlDictionaryAllot(dictionary, n); 2718 } 2719 2720 void 2721 ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells) 2722 { 2723 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells); 2724 FICL_IGNORE(vm); 2725 ficlDictionaryAllotCells(dictionary, cells); 2726 } 2727 2728 /* 2729 * f i c l P a r s e W o r d 2730 * From the standard, section 3.4 2731 * b) Search the dictionary name space (see 3.4.2). If a definition name 2732 * matching the string is found: 2733 * 1.if interpreting, perform the interpretation semantics of the definition 2734 * (see 3.4.3.2), and continue at a); 2735 * 2.if compiling, perform the compilation semantics of the definition 2736 * (see 3.4.3.3), and continue at a). 2737 * 2738 * c) If a definition name matching the string is not found, attempt to 2739 * convert the string to a number (see 3.4.1.3). If successful: 2740 * 1.if interpreting, place the number on the data stack, and continue at a); 2741 * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place 2742 * the number on the stack (see 6.1.1780 LITERAL), and continue at a); 2743 * 2744 * d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 2745 * 2746 * (jws 4/01) Modified to be a ficlParseStep 2747 */ 2748 int 2749 ficlVmParseWord(ficlVm *vm, ficlString name) 2750 { 2751 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2752 ficlWord *tempFW; 2753 2754 FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0); 2755 FICL_STACK_CHECK(vm->dataStack, 0, 0); 2756 2757 #if FICL_WANT_LOCALS 2758 if (vm->callback.system->localsCount > 0) { 2759 tempFW = ficlSystemLookupLocal(vm->callback.system, name); 2760 } else 2761 #endif 2762 tempFW = ficlDictionaryLookup(dictionary, name); 2763 2764 if (vm->state == FICL_VM_STATE_INTERPRET) { 2765 if (tempFW != NULL) { 2766 if (ficlWordIsCompileOnly(tempFW)) { 2767 ficlVmThrowError(vm, 2768 "Error: FICL_VM_STATE_COMPILE only!"); 2769 } 2770 2771 ficlVmExecuteWord(vm, tempFW); 2772 return (1); /* true */ 2773 } 2774 } else { /* (vm->state == FICL_VM_STATE_COMPILE) */ 2775 if (tempFW != NULL) { 2776 if (ficlWordIsImmediate(tempFW)) { 2777 ficlVmExecuteWord(vm, tempFW); 2778 } else { 2779 ficlCell c; 2780 c.p = tempFW; 2781 if (tempFW->flags & FICL_WORD_INSTRUCTION) 2782 ficlDictionaryAppendUnsigned(dictionary, 2783 (ficlInteger)tempFW->code); 2784 else 2785 ficlDictionaryAppendCell(dictionary, c); 2786 } 2787 return (1); /* true */ 2788 } 2789 } 2790 2791 return (0); /* false */ 2792 } 2793