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