diff options
Diffstat (limited to 'usr/src/common/ficl/vm.c')
| -rw-r--r-- | usr/src/common/ficl/vm.c | 2785 |
1 files changed, 2785 insertions, 0 deletions
diff --git a/usr/src/common/ficl/vm.c b/usr/src/common/ficl/vm.c new file mode 100644 index 0000000000..39bd41e8b2 --- /dev/null +++ b/usr/src/common/ficl/vm.c @@ -0,0 +1,2785 @@ +/* + * v m . c + * Forth Inspired Command Language - virtual machine methods + * Author: John Sadler (john_sadler@alum.mit.edu) + * Created: 19 July 1997 + * $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $ + */ +/* + * This file implements the virtual machine of Ficl. Each virtual + * machine retains the state of an interpreter. A virtual machine + * owns a pair of stacks for parameters and return addresses, as + * well as a pile of state variables and the two dedicated registers + * of the interpreter. + */ +/* + * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) + * All rights reserved. + * + * Get the latest Ficl release at http://ficl.sourceforge.net + * + * I am interested in hearing from anyone who uses Ficl. If you have + * a problem, a success story, a defect, an enhancement request, or + * if you would like to contribute to the Ficl release, please + * contact me by email at the address above. + * + * L I C E N S E and D I S C L A I M E R + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "ficl.h" + +#if FICL_ROBUST >= 2 +#define FICL_VM_CHECK(vm) \ + FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord) +#else +#define FICL_VM_CHECK(vm) +#endif + +/* + * v m B r a n c h R e l a t i v e + */ +void +ficlVmBranchRelative(ficlVm *vm, int offset) +{ + vm->ip += offset; +} + +/* + * v m C r e a t e + * Creates a virtual machine either from scratch (if vm is NULL on entry) + * or by resizing and reinitializing an existing VM to the specified stack + * sizes. + */ +ficlVm * +ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack) +{ + if (vm == NULL) { + vm = (ficlVm *)ficlMalloc(sizeof (ficlVm)); + FICL_ASSERT(NULL, vm); + memset(vm, 0, sizeof (ficlVm)); + } + + if (vm->dataStack) + ficlStackDestroy(vm->dataStack); + vm->dataStack = ficlStackCreate(vm, "data", nPStack); + + if (vm->returnStack) + ficlStackDestroy(vm->returnStack); + vm->returnStack = ficlStackCreate(vm, "return", nRStack); + +#if FICL_WANT_FLOAT + if (vm->floatStack) + ficlStackDestroy(vm->floatStack); + vm->floatStack = ficlStackCreate(vm, "float", nPStack); +#endif + + ficlVmReset(vm); + return (vm); +} + +/* + * v m D e l e t e + * Free all memory allocated to the specified VM and its subordinate + * structures. + */ +void +ficlVmDestroy(ficlVm *vm) +{ + if (vm) { + ficlFree(vm->dataStack); + ficlFree(vm->returnStack); +#if FICL_WANT_FLOAT + ficlFree(vm->floatStack); +#endif + ficlFree(vm); + } +} + +/* + * v m E x e c u t e + * Sets up the specified word to be run by the inner interpreter. + * Executes the word's code part immediately, but in the case of + * colon definition, the definition itself needs the inner interpreter + * to complete. This does not happen until control reaches ficlExec + */ +void +ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord) +{ + ficlVmInnerLoop(vm, pWord); +} + +static void +ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip) +{ + ficlIp destination; + switch ((ficlInstruction)(*ip)) { + case ficlInstructionBranchParenWithCheck: + *ip = (ficlWord *)ficlInstructionBranchParen; + goto RUNTIME_FIXUP; + + case ficlInstructionBranch0ParenWithCheck: + *ip = (ficlWord *)ficlInstructionBranch0Paren; +RUNTIME_FIXUP: + ip++; + destination = ip + *(ficlInteger *)ip; + switch ((ficlInstruction)*destination) { + case ficlInstructionBranchParenWithCheck: + /* preoptimize where we're jumping to */ + ficlVmOptimizeJumpToJump(vm, destination); + case ficlInstructionBranchParen: + destination++; + destination += *(ficlInteger *)destination; + *ip = (ficlWord *)(destination - ip); + break; + } + } +} + +/* + * v m I n n e r L o o p + * the mysterious inner interpreter... + * This loop is the address interpreter that makes colon definitions + * work. Upon entry, it assumes that the IP points to an entry in + * a definition (the body of a colon word). It runs one word at a time + * until something does vmThrow. The catcher for this is expected to exist + * in the calling code. + * vmThrow gets you out of this loop with a longjmp() + */ + +#if FICL_ROBUST <= 1 + /* turn off stack checking for primitives */ +#define _CHECK_STACK(stack, top, pop, push) +#else + +#define _CHECK_STACK(stack, top, pop, push) \ + ficlStackCheckNospill(stack, top, pop, push) + +FICL_PLATFORM_INLINE void +ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells, + int pushCells) +{ + /* + * Why save and restore stack->top? + * So the simple act of stack checking doesn't force a "register" spill, + * which might mask bugs (places where we needed to spill but didn't). + * --lch + */ + ficlCell *oldTop = stack->top; + stack->top = top; + ficlStackCheck(stack, popCells, pushCells); + stack->top = oldTop; +} + +#endif /* FICL_ROBUST <= 1 */ + +#define CHECK_STACK(pop, push) \ + _CHECK_STACK(vm->dataStack, dataTop, pop, push) +#define CHECK_FLOAT_STACK(pop, push) \ + _CHECK_STACK(vm->floatStack, floatTop, pop, push) +#define CHECK_RETURN_STACK(pop, push) \ + _CHECK_STACK(vm->returnStack, returnTop, pop, push) + +#if FICL_WANT_FLOAT +#define FLOAT_LOCAL_VARIABLE_SPILL \ + vm->floatStack->top = floatTop; +#define FLOAT_LOCAL_VARIABLE_REFILL \ + floatTop = vm->floatStack->top; +#else +#define FLOAT_LOCAL_VARIABLE_SPILL +#define FLOAT_LOCAL_VARIABLE_REFILL +#endif /* FICL_WANT_FLOAT */ + +#if FICL_WANT_LOCALS +#define LOCALS_LOCAL_VARIABLE_SPILL \ + vm->returnStack->frame = frame; +#define LOCALS_LOCAL_VARIABLE_REFILL \ + frame = vm->returnStack->frame; +#else +#define LOCALS_LOCAL_VARIABLE_SPILL +#define LOCALS_LOCAL_VARIABLE_REFILL +#endif /* FICL_WANT_FLOAT */ + +#define LOCAL_VARIABLE_SPILL \ + vm->ip = (ficlIp)ip; \ + vm->dataStack->top = dataTop; \ + vm->returnStack->top = returnTop; \ + FLOAT_LOCAL_VARIABLE_SPILL \ + LOCALS_LOCAL_VARIABLE_SPILL + +#define LOCAL_VARIABLE_REFILL \ + ip = (ficlInstruction *)vm->ip; \ + dataTop = vm->dataStack->top; \ + returnTop = vm->returnStack->top; \ + FLOAT_LOCAL_VARIABLE_REFILL \ + LOCALS_LOCAL_VARIABLE_REFILL + +void +ficlVmInnerLoop(ficlVm *vm, ficlWord *fw) +{ + register ficlInstruction *ip; + register ficlCell *dataTop; + register ficlCell *returnTop; +#if FICL_WANT_FLOAT + register ficlCell *floatTop; + ficlFloat f; +#endif /* FICL_WANT_FLOAT */ +#if FICL_WANT_LOCALS + register ficlCell *frame; +#endif /* FICL_WANT_LOCALS */ + jmp_buf *oldExceptionHandler; + jmp_buf exceptionHandler; + int except; + int once; + int count; + ficlInstruction instruction; + ficlInteger i; + ficlUnsigned u; + ficlCell c; + ficlCountedString *s; + ficlCell *cell; + char *cp; + + once = (fw != NULL); + if (once) + count = 1; + + oldExceptionHandler = vm->exceptionHandler; + /* This has to come before the setjmp! */ + vm->exceptionHandler = &exceptionHandler; + except = setjmp(exceptionHandler); + + LOCAL_VARIABLE_REFILL; + + if (except) { + LOCAL_VARIABLE_SPILL; + vm->exceptionHandler = oldExceptionHandler; + ficlVmThrow(vm, except); + } + + for (;;) { + if (once) { + if (!count--) + break; + instruction = (ficlInstruction)((void *)fw); + } else { + instruction = *ip++; + fw = (ficlWord *)instruction; + } + +AGAIN: + switch (instruction) { + case ficlInstructionInvalid: + ficlVmThrowError(vm, + "Error: NULL instruction executed!"); + return; + + case ficlInstruction1: + case ficlInstruction2: + case ficlInstruction3: + case ficlInstruction4: + case ficlInstruction5: + case ficlInstruction6: + case ficlInstruction7: + case ficlInstruction8: + case ficlInstruction9: + case ficlInstruction10: + case ficlInstruction11: + case ficlInstruction12: + case ficlInstruction13: + case ficlInstruction14: + case ficlInstruction15: + case ficlInstruction16: + CHECK_STACK(0, 1); + (++dataTop)->i = instruction; + continue; + + case ficlInstruction0: + case ficlInstructionNeg1: + case ficlInstructionNeg2: + case ficlInstructionNeg3: + case ficlInstructionNeg4: + case ficlInstructionNeg5: + case ficlInstructionNeg6: + case ficlInstructionNeg7: + case ficlInstructionNeg8: + case ficlInstructionNeg9: + case ficlInstructionNeg10: + case ficlInstructionNeg11: + case ficlInstructionNeg12: + case ficlInstructionNeg13: + case ficlInstructionNeg14: + case ficlInstructionNeg15: + case ficlInstructionNeg16: + CHECK_STACK(0, 1); + (++dataTop)->i = ficlInstruction0 - instruction; + continue; + + /* + * stringlit: Fetch the count from the dictionary, then push + * the address and count on the stack. Finally, update ip to + * point to the first aligned address after the string text. + */ + case ficlInstructionStringLiteralParen: { + ficlUnsigned8 length; + CHECK_STACK(0, 2); + + s = (ficlCountedString *)(ip); + length = s->length; + cp = s->text; + (++dataTop)->p = cp; + (++dataTop)->i = length; + + cp += length + 1; + cp = ficlAlignPointer(cp); + ip = (void *)cp; + continue; + } + + case ficlInstructionCStringLiteralParen: + CHECK_STACK(0, 1); + + s = (ficlCountedString *)(ip); + cp = s->text + s->length + 1; + cp = ficlAlignPointer(cp); + ip = (void *)cp; + (++dataTop)->p = s; + continue; + +#if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE +#if FICL_WANT_FLOAT +FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC: + *++floatTop = cell[1]; + /* intentional fall-through */ +FLOAT_PUSH_CELL_POINTER_MINIPROC: + *++floatTop = cell[0]; + continue; + +FLOAT_POP_CELL_POINTER_MINIPROC: + cell[0] = *floatTop--; + continue; + +FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC: + cell[0] = *floatTop--; + cell[1] = *floatTop--; + continue; + +#define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC +#define FLOAT_PUSH_CELL_POINTER(cp) \ + cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC +#define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC +#define FLOAT_POP_CELL_POINTER(cp) \ + cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC +#endif /* FICL_WANT_FLOAT */ + + /* + * Think of these as little mini-procedures. + * --lch + */ +PUSH_CELL_POINTER_DOUBLE_MINIPROC: + *++dataTop = cell[1]; + /* intentional fall-through */ +PUSH_CELL_POINTER_MINIPROC: + *++dataTop = cell[0]; + continue; + +POP_CELL_POINTER_MINIPROC: + cell[0] = *dataTop--; + continue; +POP_CELL_POINTER_DOUBLE_MINIPROC: + cell[0] = *dataTop--; + cell[1] = *dataTop--; + continue; + +#define PUSH_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC +#define PUSH_CELL_POINTER(cp) \ + cell = (cp); goto PUSH_CELL_POINTER_MINIPROC +#define POP_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC +#define POP_CELL_POINTER(cp) \ + cell = (cp); goto POP_CELL_POINTER_MINIPROC + +BRANCH_MINIPROC: + ip += *(ficlInteger *)ip; + continue; + +#define BRANCH() goto BRANCH_MINIPROC + +EXIT_FUNCTION_MINIPROC: + ip = (ficlInstruction *)((returnTop--)->p); + continue; + +#define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC + +#else /* FICL_WANT_SIZE */ + +#if FICL_WANT_FLOAT +#define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue +#define FLOAT_PUSH_CELL_POINTER(cp) \ + cell = (cp); *++floatTop = *cell; continue +#define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue +#define FLOAT_POP_CELL_POINTER(cp) \ + cell = (cp); *cell = *floatTop--; continue +#endif /* FICL_WANT_FLOAT */ + +#define PUSH_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue +#define PUSH_CELL_POINTER(cp) \ + cell = (cp); *++dataTop = *cell; continue +#define POP_CELL_POINTER_DOUBLE(cp) \ + cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue +#define POP_CELL_POINTER(cp) \ + cell = (cp); *cell = *dataTop--; continue + +#define BRANCH() ip += *(ficlInteger *)ip; continue +#define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue + +#endif /* FICL_WANT_SIZE */ + + + /* + * This is the runtime for (literal). It assumes that it is + * part of a colon definition, and that the next ficlCell + * contains a value to be pushed on the parameter stack at + * runtime. This code is compiled by "literal". + */ + + case ficlInstructionLiteralParen: + CHECK_STACK(0, 1); + (++dataTop)->i = *ip++; + continue; + + case ficlInstruction2LiteralParen: + CHECK_STACK(0, 2); + (++dataTop)->i = ip[1]; + (++dataTop)->i = ip[0]; + ip += 2; + continue; + +#if FICL_WANT_LOCALS + /* + * Link a frame on the return stack, reserving nCells of space + * for locals - the value of nCells is the next ficlCell in + * the instruction stream. + * 1) Push frame onto returnTop + * 2) frame = returnTop + * 3) returnTop += nCells + */ + case ficlInstructionLinkParen: { + ficlInteger nCells = *ip++; + (++returnTop)->p = frame; + frame = returnTop + 1; + returnTop += nCells; + continue; + } + + /* + * Unink a stack frame previously created by stackLink + * 1) dataTop = frame + * 2) frame = pop() + */ + case ficlInstructionUnlinkParen: + returnTop = frame - 1; + frame = (returnTop--)->p; + continue; + + /* + * Immediate - cfa of a local while compiling - when executed, + * compiles code to fetch the value of a local given the + * local's index in the word's pfa + */ +#if FICL_WANT_FLOAT + case ficlInstructionGetF2LocalParen: + FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++); + + case ficlInstructionGetFLocalParen: + FLOAT_PUSH_CELL_POINTER(frame + *ip++); + + case ficlInstructionToF2LocalParen: + FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++); + + case ficlInstructionToFLocalParen: + FLOAT_POP_CELL_POINTER(frame + *ip++); +#endif /* FICL_WANT_FLOAT */ + + case ficlInstructionGet2LocalParen: + PUSH_CELL_POINTER_DOUBLE(frame + *ip++); + + case ficlInstructionGetLocalParen: + PUSH_CELL_POINTER(frame + *ip++); + + /* + * Immediate - cfa of a local while compiling - when executed, + * compiles code to store the value of a local given the + * local's index in the word's pfa + */ + + case ficlInstructionTo2LocalParen: + POP_CELL_POINTER_DOUBLE(frame + *ip++); + + case ficlInstructionToLocalParen: + POP_CELL_POINTER(frame + *ip++); + + /* + * Silly little minor optimizations. + * --lch + */ + case ficlInstructionGetLocal0: + PUSH_CELL_POINTER(frame); + + case ficlInstructionGetLocal1: + PUSH_CELL_POINTER(frame + 1); + + case ficlInstructionGet2Local0: + PUSH_CELL_POINTER_DOUBLE(frame); + + case ficlInstructionToLocal0: + POP_CELL_POINTER(frame); + + case ficlInstructionToLocal1: + POP_CELL_POINTER(frame + 1); + + case ficlInstructionTo2Local0: + POP_CELL_POINTER_DOUBLE(frame); + +#endif /* FICL_WANT_LOCALS */ + + case ficlInstructionPlus: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i += i; + continue; + + case ficlInstructionMinus: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i -= i; + continue; + + case ficlInstruction1Plus: + CHECK_STACK(1, 1); + dataTop->i++; + continue; + + case ficlInstruction1Minus: + CHECK_STACK(1, 1); + dataTop->i--; + continue; + + case ficlInstruction2Plus: + CHECK_STACK(1, 1); + dataTop->i += 2; + continue; + + case ficlInstruction2Minus: + CHECK_STACK(1, 1); + dataTop->i -= 2; + continue; + + case ficlInstructionDup: { + ficlInteger i = dataTop->i; + CHECK_STACK(0, 1); + (++dataTop)->i = i; + continue; + } + + case ficlInstructionQuestionDup: + CHECK_STACK(1, 2); + + if (dataTop->i != 0) { + dataTop[1] = dataTop[0]; + dataTop++; + } + + continue; + + case ficlInstructionSwap: { + ficlCell swap; + CHECK_STACK(2, 2); + swap = dataTop[0]; + dataTop[0] = dataTop[-1]; + dataTop[-1] = swap; + } + continue; + + case ficlInstructionDrop: + CHECK_STACK(1, 0); + dataTop--; + continue; + + case ficlInstruction2Drop: + CHECK_STACK(2, 0); + dataTop -= 2; + continue; + + case ficlInstruction2Dup: + CHECK_STACK(2, 4); + dataTop[1] = dataTop[-1]; + dataTop[2] = *dataTop; + dataTop += 2; + continue; + + case ficlInstructionOver: + CHECK_STACK(2, 3); + dataTop[1] = dataTop[-1]; + dataTop++; + continue; + + case ficlInstruction2Over: + CHECK_STACK(4, 6); + dataTop[1] = dataTop[-3]; + dataTop[2] = dataTop[-2]; + dataTop += 2; + continue; + + case ficlInstructionPick: + CHECK_STACK(1, 0); + i = dataTop->i; + if (i < 0) + continue; + CHECK_STACK(i + 2, i + 3); + *dataTop = dataTop[-i - 1]; + continue; + + /* + * Do stack rot. + * rot ( 1 2 3 -- 2 3 1 ) + */ + case ficlInstructionRot: + i = 2; + goto ROLL; + + /* + * Do stack roll. + * roll ( n -- ) + */ + case ficlInstructionRoll: + CHECK_STACK(1, 0); + i = (dataTop--)->i; + + if (i < 1) + continue; + +ROLL: + CHECK_STACK(i+1, i+2); + c = dataTop[-i]; + memmove(dataTop - i, dataTop - (i - 1), + i * sizeof (ficlCell)); + *dataTop = c; + continue; + + /* + * Do stack -rot. + * -rot ( 1 2 3 -- 3 1 2 ) + */ + case ficlInstructionMinusRot: + i = 2; + goto MINUSROLL; + + /* + * Do stack -roll. + * -roll ( n -- ) + */ + case ficlInstructionMinusRoll: + CHECK_STACK(1, 0); + i = (dataTop--)->i; + + if (i < 1) + continue; + +MINUSROLL: + CHECK_STACK(i+1, i+2); + c = *dataTop; + memmove(dataTop - (i - 1), dataTop - i, + i * sizeof (ficlCell)); + dataTop[-i] = c; + + continue; + + /* + * Do stack 2swap + * 2swap ( 1 2 3 4 -- 3 4 1 2 ) + */ + case ficlInstruction2Swap: { + ficlCell c2; + CHECK_STACK(4, 4); + + c = *dataTop; + c2 = dataTop[-1]; + + *dataTop = dataTop[-2]; + dataTop[-1] = dataTop[-3]; + + dataTop[-2] = c; + dataTop[-3] = c2; + continue; + } + + case ficlInstructionPlusStore: { + ficlCell *cell; + CHECK_STACK(2, 0); + cell = (ficlCell *)(dataTop--)->p; + cell->i += (dataTop--)->i; + continue; + } + + case ficlInstructionQuadFetch: { + ficlUnsigned32 *integer32; + CHECK_STACK(1, 1); + integer32 = (ficlUnsigned32 *)dataTop->i; + dataTop->u = (ficlUnsigned)*integer32; + continue; + } + + case ficlInstructionQuadStore: { + ficlUnsigned32 *integer32; + CHECK_STACK(2, 0); + integer32 = (ficlUnsigned32 *)(dataTop--)->p; + *integer32 = (ficlUnsigned32)((dataTop--)->u); + continue; + } + + case ficlInstructionWFetch: { + ficlUnsigned16 *integer16; + CHECK_STACK(1, 1); + integer16 = (ficlUnsigned16 *)dataTop->p; + dataTop->u = ((ficlUnsigned)*integer16); + continue; + } + + case ficlInstructionWStore: { + ficlUnsigned16 *integer16; + CHECK_STACK(2, 0); + integer16 = (ficlUnsigned16 *)(dataTop--)->p; + *integer16 = (ficlUnsigned16)((dataTop--)->u); + continue; + } + + case ficlInstructionCFetch: { + ficlUnsigned8 *integer8; + CHECK_STACK(1, 1); + integer8 = (ficlUnsigned8 *)dataTop->p; + dataTop->u = ((ficlUnsigned)*integer8); + continue; + } + + case ficlInstructionCStore: { + ficlUnsigned8 *integer8; + CHECK_STACK(2, 0); + integer8 = (ficlUnsigned8 *)(dataTop--)->p; + *integer8 = (ficlUnsigned8)((dataTop--)->u); + continue; + } + + + /* + * l o g i c a n d c o m p a r i s o n s + */ + + case ficlInstruction0Equals: + CHECK_STACK(1, 1); + dataTop->i = FICL_BOOL(dataTop->i == 0); + continue; + + case ficlInstruction0Less: + CHECK_STACK(1, 1); + dataTop->i = FICL_BOOL(dataTop->i < 0); + continue; + + case ficlInstruction0Greater: + CHECK_STACK(1, 1); + dataTop->i = FICL_BOOL(dataTop->i > 0); + continue; + + case ficlInstructionEquals: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i = FICL_BOOL(dataTop->i == i); + continue; + + case ficlInstructionLess: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i = FICL_BOOL(dataTop->i < i); + continue; + + case ficlInstructionULess: + CHECK_STACK(2, 1); + u = (dataTop--)->u; + dataTop->i = FICL_BOOL(dataTop->u < u); + continue; + + case ficlInstructionAnd: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i = dataTop->i & i; + continue; + + case ficlInstructionOr: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i = dataTop->i | i; + continue; + + case ficlInstructionXor: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i = dataTop->i ^ i; + continue; + + case ficlInstructionInvert: + CHECK_STACK(1, 1); + dataTop->i = ~dataTop->i; + continue; + + /* + * r e t u r n s t a c k + */ + case ficlInstructionToRStack: + CHECK_STACK(1, 0); + CHECK_RETURN_STACK(0, 1); + *++returnTop = *dataTop--; + continue; + + case ficlInstructionFromRStack: + CHECK_STACK(0, 1); + CHECK_RETURN_STACK(1, 0); + *++dataTop = *returnTop--; + continue; + + case ficlInstructionFetchRStack: + CHECK_STACK(0, 1); + CHECK_RETURN_STACK(1, 1); + *++dataTop = *returnTop; + continue; + + case ficlInstruction2ToR: + CHECK_STACK(2, 0); + CHECK_RETURN_STACK(0, 2); + *++returnTop = dataTop[-1]; + *++returnTop = dataTop[0]; + dataTop -= 2; + continue; + + case ficlInstruction2RFrom: + CHECK_STACK(0, 2); + CHECK_RETURN_STACK(2, 0); + *++dataTop = returnTop[-1]; + *++dataTop = returnTop[0]; + returnTop -= 2; + continue; + + case ficlInstruction2RFetch: + CHECK_STACK(0, 2); + CHECK_RETURN_STACK(2, 2); + *++dataTop = returnTop[-1]; + *++dataTop = returnTop[0]; + continue; + + /* + * f i l l + * CORE ( c-addr u char -- ) + * If u is greater than zero, store char in each of u + * consecutive characters of memory beginning at c-addr. + */ + case ficlInstructionFill: { + char c; + char *memory; + CHECK_STACK(3, 0); + c = (char)(dataTop--)->i; + u = (dataTop--)->u; + memory = (char *)(dataTop--)->p; + + /* + * memset() is faster than the previous hand-rolled + * solution. --lch + */ + memset(memory, c, u); + continue; + } + + /* + * l s h i f t + * l-shift CORE ( x1 u -- x2 ) + * Perform a logical left shift of u bit-places on x1, + * giving x2. Put zeroes into the least significant bits + * vacated by the shift. An ambiguous condition exists if + * u is greater than or equal to the number of bits in a + * ficlCell. + * + * r-shift CORE ( x1 u -- x2 ) + * Perform a logical right shift of u bit-places on x1, + * giving x2. Put zeroes into the most significant bits + * vacated by the shift. An ambiguous condition exists + * if u is greater than or equal to the number of bits + * in a ficlCell. + */ + case ficlInstructionLShift: { + ficlUnsigned nBits; + ficlUnsigned x1; + CHECK_STACK(2, 1); + + nBits = (dataTop--)->u; + x1 = dataTop->u; + dataTop->u = x1 << nBits; + continue; + } + + case ficlInstructionRShift: { + ficlUnsigned nBits; + ficlUnsigned x1; + CHECK_STACK(2, 1); + + nBits = (dataTop--)->u; + x1 = dataTop->u; + dataTop->u = x1 >> nBits; + continue; + } + + /* + * m a x & m i n + */ + case ficlInstructionMax: { + ficlInteger n2; + ficlInteger n1; + CHECK_STACK(2, 1); + + n2 = (dataTop--)->i; + n1 = dataTop->i; + + dataTop->i = ((n1 > n2) ? n1 : n2); + continue; + } + + case ficlInstructionMin: { + ficlInteger n2; + ficlInteger n1; + CHECK_STACK(2, 1); + + n2 = (dataTop--)->i; + n1 = dataTop->i; + + dataTop->i = ((n1 < n2) ? n1 : n2); + continue; + } + + /* + * m o v e + * CORE ( addr1 addr2 u -- ) + * If u is greater than zero, copy the contents of u + * consecutive address units at addr1 to the u consecutive + * address units at addr2. After MOVE completes, the u + * consecutive address units at addr2 contain exactly + * what the u consecutive address units at addr1 contained + * before the move. + * NOTE! This implementation assumes that a char is the same + * size as an address unit. + */ + case ficlInstructionMove: { + ficlUnsigned u; + char *addr2; + char *addr1; + CHECK_STACK(3, 0); + + u = (dataTop--)->u; + addr2 = (dataTop--)->p; + addr1 = (dataTop--)->p; + + if (u == 0) + continue; + /* + * Do the copy carefully, so as to be + * correct even if the two ranges overlap + */ + /* Which ANSI C's memmove() does for you! Yay! --lch */ + memmove(addr2, addr1, u); + continue; + } + + /* + * s t o d + * s-to-d CORE ( n -- d ) + * Convert the number n to the double-ficlCell number d with + * the same numerical value. + */ + case ficlInstructionSToD: { + ficlInteger s; + CHECK_STACK(1, 2); + + s = dataTop->i; + + /* sign extend to 64 bits.. */ + (++dataTop)->i = (s < 0) ? -1 : 0; + continue; + } + + /* + * c o m p a r e + * STRING ( c-addr1 u1 c-addr2 u2 -- n ) + * Compare the string specified by c-addr1 u1 to the string + * specified by c-addr2 u2. The strings are compared, beginning + * at the given addresses, character by character, up to the + * length of the shorter string or until a difference is found. + * If the two strings are identical, n is zero. If the two + * strings are identical up to the length of the shorter string, + * n is minus-one (-1) if u1 is less than u2 and one (1) + * otherwise. If the two strings are not identical up to the + * length of the shorter string, n is minus-one (-1) if the + * first non-matching character in the string specified by + * c-addr1 u1 has a lesser numeric value than the corresponding + * character in the string specified by c-addr2 u2 and + * one (1) otherwise. + */ + case ficlInstructionCompare: + i = FICL_FALSE; + goto COMPARE; + + + case ficlInstructionCompareInsensitive: + i = FICL_TRUE; + goto COMPARE; + +COMPARE: + { + char *cp1, *cp2; + ficlUnsigned u1, u2, uMin; + int n = 0; + + CHECK_STACK(4, 1); + u2 = (dataTop--)->u; + cp2 = (char *)(dataTop--)->p; + u1 = (dataTop--)->u; + cp1 = (char *)(dataTop--)->p; + + uMin = (u1 < u2)? u1 : u2; + for (; (uMin > 0) && (n == 0); uMin--) { + int c1 = (unsigned char)*cp1++; + int c2 = (unsigned char)*cp2++; + + if (i) { + c1 = tolower(c1); + c2 = tolower(c2); + } + n = (c1 - c2); + } + + if (n == 0) + n = (int)(u1 - u2); + + if (n < 0) + n = -1; + else if (n > 0) + n = 1; + + (++dataTop)->i = n; + continue; + } + + /* + * r a n d o m + * Ficl-specific + */ + case ficlInstructionRandom: + (++dataTop)->i = random(); + continue; + + /* + * s e e d - r a n d o m + * Ficl-specific + */ + case ficlInstructionSeedRandom: + srandom((dataTop--)->i); + continue; + + case ficlInstructionGreaterThan: { + ficlInteger x, y; + CHECK_STACK(2, 1); + y = (dataTop--)->i; + x = dataTop->i; + dataTop->i = FICL_BOOL(x > y); + continue; + } + + /* + * This function simply pops the previous instruction + * pointer and returns to the "next" loop. Used for exiting + * from within a definition. Note that exitParen is identical + * to semiParen - they are in two different functions so that + * "see" can correctly identify the end of a colon definition, + * even if it uses "exit". + */ + case ficlInstructionExitParen: + case ficlInstructionSemiParen: + EXIT_FUNCTION(); + + /* + * The first time we run "(branch)", perform a "peephole + * optimization" to see if we're jumping to another + * unconditional jump. If so, just jump directly there. + */ + case ficlInstructionBranchParenWithCheck: + LOCAL_VARIABLE_SPILL; + ficlVmOptimizeJumpToJump(vm, vm->ip - 1); + LOCAL_VARIABLE_REFILL; + goto BRANCH_PAREN; + + /* + * Same deal with branch0. + */ + case ficlInstructionBranch0ParenWithCheck: + LOCAL_VARIABLE_SPILL; + ficlVmOptimizeJumpToJump(vm, vm->ip - 1); + LOCAL_VARIABLE_REFILL; + /* intentional fall-through */ + + /* + * Runtime code for "(branch0)"; pop a flag from the stack, + * branch if 0. fall through otherwise. + * The heart of "if" and "until". + */ + case ficlInstructionBranch0Paren: + CHECK_STACK(1, 0); + + if ((dataTop--)->i) { + /* + * don't branch, but skip over branch + * relative address + */ + ip += 1; + continue; + } + /* otherwise, take branch (to else/endif/begin) */ + /* intentional fall-through! */ + + /* + * Runtime for "(branch)" -- expects a literal offset in the + * next compilation address, and branches to that location. + */ + case ficlInstructionBranchParen: +BRANCH_PAREN: + BRANCH(); + + case ficlInstructionOfParen: { + ficlUnsigned a, b; + + CHECK_STACK(2, 1); + + a = (dataTop--)->u; + b = dataTop->u; + + if (a == b) { + /* fall through */ + ip++; + /* remove CASE argument */ + dataTop--; + } else { + /* take branch to next of or endcase */ + BRANCH(); + } + + continue; + } + + case ficlInstructionDoParen: { + ficlCell index, limit; + + CHECK_STACK(2, 0); + + index = *dataTop--; + limit = *dataTop--; + + /* copy "leave" target addr to stack */ + (++returnTop)->i = *(ip++); + *++returnTop = limit; + *++returnTop = index; + + continue; + } + + case ficlInstructionQDoParen: { + ficlCell index, limit, leave; + + CHECK_STACK(2, 0); + + index = *dataTop--; + limit = *dataTop--; + + leave.i = *ip; + + if (limit.u == index.u) { + ip = leave.p; + } else { + ip++; + *++returnTop = leave; + *++returnTop = limit; + *++returnTop = index; + } + + continue; + } + + case ficlInstructionLoopParen: + case ficlInstructionPlusLoopParen: { + ficlInteger index; + ficlInteger limit; + int direction = 0; + + index = returnTop->i; + limit = returnTop[-1].i; + + if (instruction == ficlInstructionLoopParen) + index++; + else { + ficlInteger increment; + CHECK_STACK(1, 0); + increment = (dataTop--)->i; + index += increment; + direction = (increment < 0); + } + + if (direction ^ (index >= limit)) { + /* nuke the loop indices & "leave" addr */ + returnTop -= 3; + ip++; /* fall through the loop */ + } else { /* update index, branch to loop head */ + returnTop->i = index; + BRANCH(); + } + + continue; + } + + + /* + * Runtime code to break out of a do..loop construct + * Drop the loop control variables; the branch address + * past "loop" is next on the return stack. + */ + case ficlInstructionLeave: + /* almost unloop */ + returnTop -= 2; + /* exit */ + EXIT_FUNCTION(); + + case ficlInstructionUnloop: + returnTop -= 3; + continue; + + case ficlInstructionI: + *++dataTop = *returnTop; + continue; + + case ficlInstructionJ: + *++dataTop = returnTop[-3]; + continue; + + case ficlInstructionK: + *++dataTop = returnTop[-6]; + continue; + + case ficlInstructionDoesParen: { + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + dictionary->smudge->code = + (ficlPrimitive)ficlInstructionDoDoes; + dictionary->smudge->param[0].p = ip; + ip = (ficlInstruction *)((returnTop--)->p); + continue; + } + + case ficlInstructionDoDoes: { + ficlCell *cell; + ficlIp tempIP; + + CHECK_STACK(0, 1); + + cell = fw->param; + tempIP = (ficlIp)((*cell).p); + (++dataTop)->p = (cell + 1); + (++returnTop)->p = (void *)ip; + ip = (ficlInstruction *)tempIP; + continue; + } + +#if FICL_WANT_FLOAT + case ficlInstructionF2Fetch: + CHECK_FLOAT_STACK(0, 2); + CHECK_STACK(1, 0); + FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); + + case ficlInstructionFFetch: + CHECK_FLOAT_STACK(0, 1); + CHECK_STACK(1, 0); + FLOAT_PUSH_CELL_POINTER((dataTop--)->p); + + case ficlInstructionF2Store: + CHECK_FLOAT_STACK(2, 0); + CHECK_STACK(1, 0); + FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p); + + case ficlInstructionFStore: + CHECK_FLOAT_STACK(1, 0); + CHECK_STACK(1, 0); + FLOAT_POP_CELL_POINTER((dataTop--)->p); +#endif /* FICL_WANT_FLOAT */ + + /* + * two-fetch CORE ( a-addr -- x1 x2 ) + * + * Fetch the ficlCell pair x1 x2 stored at a-addr. + * x2 is stored at a-addr and x1 at the next consecutive + * ficlCell. It is equivalent to the sequence + * DUP ficlCell+ @ SWAP @ . + */ + case ficlInstruction2Fetch: + CHECK_STACK(1, 2); + PUSH_CELL_POINTER_DOUBLE((dataTop--)->p); + + /* + * fetch CORE ( a-addr -- x ) + * + * x is the value stored at a-addr. + */ + case ficlInstructionFetch: + CHECK_STACK(1, 1); + PUSH_CELL_POINTER((dataTop--)->p); + + /* + * two-store CORE ( x1 x2 a-addr -- ) + * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr + * and x1 at the next consecutive ficlCell. It is equivalent + * to the sequence SWAP OVER ! ficlCell+ ! + */ + case ficlInstruction2Store: + CHECK_STACK(3, 0); + POP_CELL_POINTER_DOUBLE((dataTop--)->p); + + /* + * store CORE ( x a-addr -- ) + * Store x at a-addr. + */ + case ficlInstructionStore: + CHECK_STACK(2, 0); + POP_CELL_POINTER((dataTop--)->p); + + case ficlInstructionComma: { + ficlDictionary *dictionary; + CHECK_STACK(1, 0); + + dictionary = ficlVmGetDictionary(vm); + ficlDictionaryAppendCell(dictionary, *dataTop--); + continue; + } + + case ficlInstructionCComma: { + ficlDictionary *dictionary; + char c; + CHECK_STACK(1, 0); + + dictionary = ficlVmGetDictionary(vm); + c = (char)(dataTop--)->i; + ficlDictionaryAppendCharacter(dictionary, c); + continue; + } + + case ficlInstructionCells: + CHECK_STACK(1, 1); + dataTop->i *= sizeof (ficlCell); + continue; + + case ficlInstructionCellPlus: + CHECK_STACK(1, 1); + dataTop->i += sizeof (ficlCell); + continue; + + case ficlInstructionStar: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i *= i; + continue; + + case ficlInstructionNegate: + CHECK_STACK(1, 1); + dataTop->i = - dataTop->i; + continue; + + case ficlInstructionSlash: + CHECK_STACK(2, 1); + i = (dataTop--)->i; + dataTop->i /= i; + continue; + + /* + * slash-mod CORE ( n1 n2 -- n3 n4 ) + * Divide n1 by n2, giving the single-ficlCell remainder n3 + * and the single-ficlCell quotient n4. An ambiguous condition + * exists if n2 is zero. If n1 and n2 differ in sign, the + * implementation-defined result returned will be the + * same as that returned by either the phrase + * >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM. + * NOTE: Ficl complies with the second phrase + * (symmetric division) + */ + case ficlInstructionSlashMod: { + ficl2Integer n1; + ficlInteger n2; + ficl2IntegerQR qr; + + CHECK_STACK(2, 2); + n2 = dataTop[0].i; + FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1); + + qr = ficl2IntegerDivideSymmetric(n1, n2); + dataTop[-1].i = qr.remainder; + dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); + continue; + } + + case ficlInstruction2Star: + CHECK_STACK(1, 1); + dataTop->i <<= 1; + continue; + + case ficlInstruction2Slash: + CHECK_STACK(1, 1); + dataTop->i >>= 1; + continue; + + case ficlInstructionStarSlash: { + ficlInteger x, y, z; + ficl2Integer prod; + CHECK_STACK(3, 1); + + z = (dataTop--)->i; + y = (dataTop--)->i; + x = dataTop->i; + + prod = ficl2IntegerMultiply(x, y); + dataTop->i = FICL_2UNSIGNED_GET_LOW( + ficl2IntegerDivideSymmetric(prod, z).quotient); + continue; + } + + case ficlInstructionStarSlashMod: { + ficlInteger x, y, z; + ficl2Integer prod; + ficl2IntegerQR qr; + + CHECK_STACK(3, 2); + + z = (dataTop--)->i; + y = dataTop[0].i; + x = dataTop[-1].i; + + prod = ficl2IntegerMultiply(x, y); + qr = ficl2IntegerDivideSymmetric(prod, z); + + dataTop[-1].i = qr.remainder; + dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient); + continue; + } + +#if FICL_WANT_FLOAT + case ficlInstructionF0: + CHECK_FLOAT_STACK(0, 1); + (++floatTop)->f = 0.0f; + continue; + + case ficlInstructionF1: + CHECK_FLOAT_STACK(0, 1); + (++floatTop)->f = 1.0f; + continue; + + case ficlInstructionFNeg1: + CHECK_FLOAT_STACK(0, 1); + (++floatTop)->f = -1.0f; + continue; + + /* + * Floating point literal execution word. + */ + case ficlInstructionFLiteralParen: + CHECK_FLOAT_STACK(0, 1); + + /* + * Yes, I'm using ->i here, + * but it's really a float. --lch + */ + (++floatTop)->i = *ip++; + continue; + + /* + * Do float addition r1 + r2. + * f+ ( r1 r2 -- r ) + */ + case ficlInstructionFPlus: + CHECK_FLOAT_STACK(2, 1); + + f = (floatTop--)->f; + floatTop->f += f; + continue; + + /* + * Do float subtraction r1 - r2. + * f- ( r1 r2 -- r ) + */ + case ficlInstructionFMinus: + CHECK_FLOAT_STACK(2, 1); + + f = (floatTop--)->f; + floatTop->f -= f; + continue; + + /* + * Do float multiplication r1 * r2. + * f* ( r1 r2 -- r ) + */ + case ficlInstructionFStar: + CHECK_FLOAT_STACK(2, 1); + + f = (floatTop--)->f; + floatTop->f *= f; + continue; + + /* + * Do float negation. + * fnegate ( r -- r ) + */ + case ficlInstructionFNegate: + CHECK_FLOAT_STACK(1, 1); + + floatTop->f = -(floatTop->f); + continue; + + /* + * Do float division r1 / r2. + * f/ ( r1 r2 -- r ) + */ + case ficlInstructionFSlash: + CHECK_FLOAT_STACK(2, 1); + + f = (floatTop--)->f; + floatTop->f /= f; + continue; + + /* + * Do float + integer r + n. + * f+i ( r n -- r ) + */ + case ficlInstructionFPlusI: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f += f; + continue; + + /* + * Do float - integer r - n. + * f-i ( r n -- r ) + */ + case ficlInstructionFMinusI: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f -= f; + continue; + + /* + * Do float * integer r * n. + * f*i ( r n -- r ) + */ + case ficlInstructionFStarI: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f *= f; + continue; + + /* + * Do float / integer r / n. + * f/i ( r n -- r ) + */ + case ficlInstructionFSlashI: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f /= f; + continue; + + /* + * Do integer - float n - r. + * i-f ( n r -- r ) + */ + case ficlInstructionIMinusF: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f = f - floatTop->f; + continue; + + /* + * Do integer / float n / r. + * i/f ( n r -- r ) + */ + case ficlInstructionISlashF: + CHECK_FLOAT_STACK(1, 1); + CHECK_STACK(1, 0); + + f = (ficlFloat)(dataTop--)->f; + floatTop->f = f / floatTop->f; + continue; + + /* + * Do integer to float conversion. + * int>float ( n -- r ) + */ + case ficlInstructionIntToFloat: + CHECK_STACK(1, 0); + CHECK_FLOAT_STACK(0, 1); + + (++floatTop)->f = ((dataTop--)->f); + continue; + + /* + * Do float to integer conversion. + * float>int ( r -- n ) + */ + case ficlInstructionFloatToInt: + CHECK_STACK(0, 1); + CHECK_FLOAT_STACK(1, 0); + + (++dataTop)->i = ((floatTop--)->i); + continue; + + /* + * Add a floating point number to contents of a variable. + * f+! ( r n -- ) + */ + case ficlInstructionFPlusStore: { + ficlCell *cell; + + CHECK_STACK(1, 0); + CHECK_FLOAT_STACK(1, 0); + + cell = (ficlCell *)(dataTop--)->p; + cell->f += (floatTop--)->f; + continue; + } + + /* + * Do float stack drop. + * fdrop ( r -- ) + */ + case ficlInstructionFDrop: + CHECK_FLOAT_STACK(1, 0); + floatTop--; + continue; + + /* + * Do float stack ?dup. + * f?dup ( r -- r ) + */ + case ficlInstructionFQuestionDup: + CHECK_FLOAT_STACK(1, 2); + + if (floatTop->f != 0) + goto FDUP; + + continue; + + /* + * Do float stack dup. + * fdup ( r -- r r ) + */ + case ficlInstructionFDup: + CHECK_FLOAT_STACK(1, 2); + +FDUP: + floatTop[1] = floatTop[0]; + floatTop++; + continue; + + /* + * Do float stack swap. + * fswap ( r1 r2 -- r2 r1 ) + */ + case ficlInstructionFSwap: + CHECK_FLOAT_STACK(2, 2); + + c = floatTop[0]; + floatTop[0] = floatTop[-1]; + floatTop[-1] = c; + continue; + + /* + * Do float stack 2drop. + * f2drop ( r r -- ) + */ + case ficlInstructionF2Drop: + CHECK_FLOAT_STACK(2, 0); + + floatTop -= 2; + continue; + + /* + * Do float stack 2dup. + * f2dup ( r1 r2 -- r1 r2 r1 r2 ) + */ + case ficlInstructionF2Dup: + CHECK_FLOAT_STACK(2, 4); + + floatTop[1] = floatTop[-1]; + floatTop[2] = *floatTop; + floatTop += 2; + continue; + + /* + * Do float stack over. + * fover ( r1 r2 -- r1 r2 r1 ) + */ + case ficlInstructionFOver: + CHECK_FLOAT_STACK(2, 3); + + floatTop[1] = floatTop[-1]; + floatTop++; + continue; + + /* + * Do float stack 2over. + * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 ) + */ + case ficlInstructionF2Over: + CHECK_FLOAT_STACK(4, 6); + + floatTop[1] = floatTop[-2]; + floatTop[2] = floatTop[-1]; + floatTop += 2; + continue; + + /* + * Do float stack pick. + * fpick ( n -- r ) + */ + case ficlInstructionFPick: + CHECK_STACK(1, 0); + c = *dataTop--; + CHECK_FLOAT_STACK(c.i+2, c.i+3); + + floatTop[1] = floatTop[- c.i - 1]; + continue; + + /* + * Do float stack rot. + * frot ( r1 r2 r3 -- r2 r3 r1 ) + */ + case ficlInstructionFRot: + i = 2; + goto FROLL; + + /* + * Do float stack roll. + * froll ( n -- ) + */ + case ficlInstructionFRoll: + CHECK_STACK(1, 0); + i = (dataTop--)->i; + + if (i < 1) + continue; + +FROLL: + CHECK_FLOAT_STACK(i+1, i+2); + c = floatTop[-i]; + memmove(floatTop - i, floatTop - (i - 1), + i * sizeof (ficlCell)); + *floatTop = c; + + continue; + + /* + * Do float stack -rot. + * f-rot ( r1 r2 r3 -- r3 r1 r2 ) + */ + case ficlInstructionFMinusRot: + i = 2; + goto FMINUSROLL; + + + /* + * Do float stack -roll. + * f-roll ( n -- ) + */ + case ficlInstructionFMinusRoll: + CHECK_STACK(1, 0); + i = (dataTop--)->i; + + if (i < 1) + continue; + +FMINUSROLL: + CHECK_FLOAT_STACK(i+1, i+2); + c = *floatTop; + memmove(floatTop - (i - 1), floatTop - i, + i * sizeof (ficlCell)); + floatTop[-i] = c; + + continue; + + /* + * Do float stack 2swap + * f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 ) + */ + case ficlInstructionF2Swap: { + ficlCell c2; + CHECK_FLOAT_STACK(4, 4); + + c = *floatTop; + c2 = floatTop[-1]; + + *floatTop = floatTop[-2]; + floatTop[-1] = floatTop[-3]; + + floatTop[-2] = c; + floatTop[-3] = c2; + continue; + } + + /* + * Do float 0= comparison r = 0.0. + * f0= ( r -- T/F ) + */ + case ficlInstructionF0Equals: + CHECK_FLOAT_STACK(1, 0); + CHECK_STACK(0, 1); + + (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f); + continue; + + /* + * Do float 0< comparison r < 0.0. + * f0< ( r -- T/F ) + */ + case ficlInstructionF0Less: + CHECK_FLOAT_STACK(1, 0); + CHECK_STACK(0, 1); + + (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f); + continue; + + /* + * Do float 0> comparison r > 0.0. + * f0> ( r -- T/F ) + */ + case ficlInstructionF0Greater: + CHECK_FLOAT_STACK(1, 0); + CHECK_STACK(0, 1); + + (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f); + continue; + + /* + * Do float = comparison r1 = r2. + * f= ( r1 r2 -- T/F ) + */ + case ficlInstructionFEquals: + CHECK_FLOAT_STACK(2, 0); + CHECK_STACK(0, 1); + + f = (floatTop--)->f; + (++dataTop)->i = FICL_BOOL((floatTop--)->f == f); + continue; + + /* + * Do float < comparison r1 < r2. + * f< ( r1 r2 -- T/F ) + */ + case ficlInstructionFLess: + CHECK_FLOAT_STACK(2, 0); + CHECK_STACK(0, 1); + + f = (floatTop--)->f; + (++dataTop)->i = FICL_BOOL((floatTop--)->f < f); + continue; + + /* + * Do float > comparison r1 > r2. + * f> ( r1 r2 -- T/F ) + */ + case ficlInstructionFGreater: + CHECK_FLOAT_STACK(2, 0); + CHECK_STACK(0, 1); + + f = (floatTop--)->f; + (++dataTop)->i = FICL_BOOL((floatTop--)->f > f); + continue; + + + /* + * Move float to param stack (assumes they both fit in a + * single ficlCell) f>s + */ + case ficlInstructionFFrom: + CHECK_FLOAT_STACK(1, 0); + CHECK_STACK(0, 1); + + *++dataTop = *floatTop--; + continue; + + case ficlInstructionToF: + CHECK_FLOAT_STACK(0, 1); + CHECK_STACK(1, 0); + + *++floatTop = *dataTop--; + continue; + +#endif /* FICL_WANT_FLOAT */ + + /* + * c o l o n P a r e n + * This is the code that executes a colon definition. It + * assumes that the virtual machine is running a "next" loop + * (See the vm.c for its implementation of member function + * vmExecute()). The colon code simply copies the address of + * the first word in the list of words to interpret into IP + * after saving its old value. When we return to the "next" + * loop, the virtual machine will call the code for each + * word in turn. + */ + case ficlInstructionColonParen: + (++returnTop)->p = (void *)ip; + ip = (ficlInstruction *)(fw->param); + continue; + + case ficlInstructionCreateParen: + CHECK_STACK(0, 1); + (++dataTop)->p = (fw->param + 1); + continue; + + case ficlInstructionVariableParen: + CHECK_STACK(0, 1); + (++dataTop)->p = fw->param; + continue; + + /* + * c o n s t a n t P a r e n + * This is the run-time code for "constant". It simply returns + * the contents of its word's first data ficlCell. + */ + +#if FICL_WANT_FLOAT + case ficlInstructionF2ConstantParen: + CHECK_FLOAT_STACK(0, 2); + FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param); + + case ficlInstructionFConstantParen: + CHECK_FLOAT_STACK(0, 1); + FLOAT_PUSH_CELL_POINTER(fw->param); +#endif /* FICL_WANT_FLOAT */ + + case ficlInstruction2ConstantParen: + CHECK_STACK(0, 2); + PUSH_CELL_POINTER_DOUBLE(fw->param); + + case ficlInstructionConstantParen: + CHECK_STACK(0, 1); + PUSH_CELL_POINTER(fw->param); + +#if FICL_WANT_USER + case ficlInstructionUserParen: { + ficlInteger i = fw->param[0].i; + (++dataTop)->p = &vm->user[i]; + continue; + } +#endif + + default: + /* + * Clever hack, or evil coding? You be the judge. + * + * If the word we've been asked to execute is in fact + * an *instruction*, we grab the instruction, stow it + * in "i" (our local cache of *ip), and *jump* to the + * top of the switch statement. --lch + */ + if (((ficlInstruction)fw->code > + ficlInstructionInvalid) && + ((ficlInstruction)fw->code < ficlInstructionLast)) { + instruction = (ficlInstruction)fw->code; + goto AGAIN; + } + + LOCAL_VARIABLE_SPILL; + (vm)->runningWord = fw; + fw->code(vm); + LOCAL_VARIABLE_REFILL; + continue; + } + } + + LOCAL_VARIABLE_SPILL; + vm->exceptionHandler = oldExceptionHandler; +} + +/* + * v m G e t D i c t + * Returns the address dictionary for this VM's system + */ +ficlDictionary * +ficlVmGetDictionary(ficlVm *vm) +{ + FICL_VM_ASSERT(vm, vm); + return (vm->callback.system->dictionary); +} + +/* + * v m G e t S t r i n g + * Parses a string out of the VM input buffer and copies up to the first + * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a + * ficlCountedString. The destination string is NULL terminated. + * + * Returns the address of the first unused character in the dest buffer. + */ +char * +ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter) +{ + ficlString s = ficlVmParseStringEx(vm, delimiter, 0); + + if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) { + FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX); + } + + strncpy(counted->text, FICL_STRING_GET_POINTER(s), + FICL_STRING_GET_LENGTH(s)); + counted->text[FICL_STRING_GET_LENGTH(s)] = '\0'; + counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); + + return (counted->text + FICL_STRING_GET_LENGTH(s) + 1); +} + +/* + * v m G e t W o r d + * vmGetWord calls vmGetWord0 repeatedly until it gets a string with + * non-zero length. + */ +ficlString +ficlVmGetWord(ficlVm *vm) +{ + ficlString s = ficlVmGetWord0(vm); + + if (FICL_STRING_GET_LENGTH(s) == 0) { + ficlVmThrow(vm, FICL_VM_STATUS_RESTART); + } + + return (s); +} + +/* + * v m G e t W o r d 0 + * Skip leading whitespace and parse a space delimited word from the tib. + * Returns the start address and length of the word. Updates the tib + * to reflect characters consumed, including the trailing delimiter. + * If there's nothing of interest in the tib, returns zero. This function + * does not use vmParseString because it uses isspace() rather than a + * single delimiter character. + */ +ficlString +ficlVmGetWord0(ficlVm *vm) +{ + char *trace = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + ficlString s; + ficlUnsigned length = 0; + char c = 0; + + trace = ficlStringSkipSpace(trace, stop); + FICL_STRING_SET_POINTER(s, trace); + + /* Please leave this loop this way; it makes Purify happier. --lch */ + for (;;) { + if (trace == stop) + break; + c = *trace; + if (isspace((unsigned char)c)) + break; + length++; + trace++; + } + + FICL_STRING_SET_LENGTH(s, length); + + /* skip one trailing delimiter */ + if ((trace != stop) && isspace((unsigned char)c)) + trace++; + + ficlVmUpdateTib(vm, trace); + + return (s); +} + +/* + * v m G e t W o r d T o P a d + * Does vmGetWord and copies the result to the pad as a NULL terminated + * string. Returns the length of the string. If the string is too long + * to fit in the pad, it is truncated. + */ +int +ficlVmGetWordToPad(ficlVm *vm) +{ + ficlString s; + char *pad = (char *)vm->pad; + s = ficlVmGetWord(vm); + + if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE) + FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE); + + strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s)); + pad[FICL_STRING_GET_LENGTH(s)] = '\0'; + return ((int)(FICL_STRING_GET_LENGTH(s))); +} + +/* + * v m P a r s e S t r i n g + * Parses a string out of the input buffer using the delimiter + * specified. Skips leading delimiters, marks the start of the string, + * and counts characters to the next delimiter it encounters. It then + * updates the vm input buffer to consume all these chars, including the + * trailing delimiter. + * Returns the address and length of the parsed string, not including the + * trailing delimiter. + */ +ficlString +ficlVmParseString(ficlVm *vm, char delimiter) +{ + return (ficlVmParseStringEx(vm, delimiter, 1)); +} + +ficlString +ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters) +{ + ficlString s; + char *trace = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + char c; + + if (skipLeadingDelimiters) { + while ((trace != stop) && (*trace == delimiter)) + trace++; + } + + FICL_STRING_SET_POINTER(s, trace); /* mark start of text */ + + /* find next delimiter or end of line */ + for (c = *trace; + (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n'); + c = *++trace) { + ; + } + + /* set length of result */ + FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s)); + + /* gobble trailing delimiter */ + if ((trace != stop) && (*trace == delimiter)) + trace++; + + ficlVmUpdateTib(vm, trace); + return (s); +} + + +/* + * v m P o p + */ +ficlCell +ficlVmPop(ficlVm *vm) +{ + return (ficlStackPop(vm->dataStack)); +} + +/* + * v m P u s h + */ +void +ficlVmPush(ficlVm *vm, ficlCell c) +{ + ficlStackPush(vm->dataStack, c); +} + +/* + * v m P o p I P + */ +void +ficlVmPopIP(ficlVm *vm) +{ + vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack)); +} + +/* + * v m P u s h I P + */ +void +ficlVmPushIP(ficlVm *vm, ficlIp newIP) +{ + ficlStackPushPointer(vm->returnStack, (void *)vm->ip); + vm->ip = newIP; +} + +/* + * v m P u s h T i b + * Binds the specified input string to the VM and clears >IN (the index) + */ +void +ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib) +{ + if (pSaveTib) { + *pSaveTib = vm->tib; + } + vm->tib.text = text; + vm->tib.end = text + nChars; + vm->tib.index = 0; +} + +void +ficlVmPopTib(ficlVm *vm, ficlTIB *pTib) +{ + if (pTib) { + vm->tib = *pTib; + } +} + +/* + * v m Q u i t + */ +void +ficlVmQuit(ficlVm *vm) +{ + ficlStackReset(vm->returnStack); + vm->restart = 0; + vm->ip = NULL; + vm->runningWord = NULL; + vm->state = FICL_VM_STATE_INTERPRET; + vm->tib.text = NULL; + vm->tib.end = NULL; + vm->tib.index = 0; + vm->pad[0] = '\0'; + vm->sourceId.i = 0; +} + +/* + * v m R e s e t + */ +void +ficlVmReset(ficlVm *vm) +{ + ficlVmQuit(vm); + ficlStackReset(vm->dataStack); +#if FICL_WANT_FLOAT + ficlStackReset(vm->floatStack); +#endif + vm->base = 10; +} + +/* + * v m S e t T e x t O u t + * Binds the specified output callback to the vm. If you pass NULL, + * binds the default output function (ficlTextOut) + */ +void +ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut) +{ + vm->callback.textOut = textOut; +} + +void +ficlVmTextOut(ficlVm *vm, char *text) +{ + ficlCallbackTextOut((ficlCallback *)vm, text); +} + + +void +ficlVmErrorOut(ficlVm *vm, char *text) +{ + ficlCallbackErrorOut((ficlCallback *)vm, text); +} + + +/* + * v m T h r o w + */ +void +ficlVmThrow(ficlVm *vm, int except) +{ + if (vm->exceptionHandler) + longjmp(*(vm->exceptionHandler), except); +} + +void +ficlVmThrowError(ficlVm *vm, char *fmt, ...) +{ + va_list list; + + va_start(list, fmt); + vsprintf(vm->pad, fmt, list); + va_end(list); + strcat(vm->pad, "\n"); + + ficlVmErrorOut(vm, vm->pad); + longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); +} + +void +ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list) +{ + vsprintf(vm->pad, fmt, list); + /* + * well, we can try anyway, we're certainly not + * returning to our caller! + */ + va_end(list); + strcat(vm->pad, "\n"); + + ficlVmErrorOut(vm, vm->pad); + longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT); +} + +/* + * f i c l E v a l u a t e + * Wrapper for ficlExec() which sets SOURCE-ID to -1. + */ +int +ficlVmEvaluate(ficlVm *vm, char *s) +{ + int returnValue; + ficlCell id = vm->sourceId; + ficlString string; + vm->sourceId.i = -1; + FICL_STRING_SET_FROM_CSTRING(string, s); + returnValue = ficlVmExecuteString(vm, string); + vm->sourceId = id; + return (returnValue); +} + +/* + * f i c l E x e c + * Evaluates a block of input text in the context of the + * specified interpreter. Emits any requested output to the + * interpreter's output function. + * + * Contains the "inner interpreter" code in a tight loop + * + * Returns one of the VM_XXXX codes defined in ficl.h: + * VM_OUTOFTEXT is the normal exit condition + * VM_ERREXIT means that the interpreter encountered a syntax error + * and the vm has been reset to recover (some or all + * of the text block got ignored + * VM_USEREXIT means that the user executed the "bye" command + * to shut down the interpreter. This would be a good + * time to delete the vm, etc -- or you can ignore this + * signal. + */ +int +ficlVmExecuteString(ficlVm *vm, ficlString s) +{ + ficlSystem *system = vm->callback.system; + ficlDictionary *dictionary = system->dictionary; + + int except; + jmp_buf vmState; + jmp_buf *oldState; + ficlTIB saveficlTIB; + + FICL_VM_ASSERT(vm, vm); + FICL_VM_ASSERT(vm, system->interpreterLoop[0]); + + ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s), + FICL_STRING_GET_LENGTH(s), &saveficlTIB); + + /* + * Save and restore VM's jmp_buf to enable nested calls to ficlExec + */ + oldState = vm->exceptionHandler; + + /* This has to come before the setjmp! */ + vm->exceptionHandler = &vmState; + except = setjmp(vmState); + + switch (except) { + case 0: + if (vm->restart) { + vm->runningWord->code(vm); + vm->restart = 0; + } else { /* set VM up to interpret text */ + ficlVmPushIP(vm, &(system->interpreterLoop[0])); + } + + ficlVmInnerLoop(vm, 0); + break; + + case FICL_VM_STATUS_RESTART: + vm->restart = 1; + except = FICL_VM_STATUS_OUT_OF_TEXT; + break; + + case FICL_VM_STATUS_OUT_OF_TEXT: + ficlVmPopIP(vm); +#if 0 /* we dont output prompt in loader */ + if ((vm->state != FICL_VM_STATE_COMPILE) && + (vm->sourceId.i == 0)) + ficlVmTextOut(vm, FICL_PROMPT); +#endif + break; + + case FICL_VM_STATUS_USER_EXIT: + case FICL_VM_STATUS_INNER_EXIT: + case FICL_VM_STATUS_BREAK: + break; + + case FICL_VM_STATUS_QUIT: + if (vm->state == FICL_VM_STATE_COMPILE) { + ficlDictionaryAbortDefinition(dictionary); +#if FICL_WANT_LOCALS + ficlDictionaryEmpty(system->locals, + system->locals->forthWordlist->size); +#endif + } + ficlVmQuit(vm); + break; + + case FICL_VM_STATUS_ERROR_EXIT: + case FICL_VM_STATUS_ABORT: + case FICL_VM_STATUS_ABORTQ: + default: /* user defined exit code?? */ + if (vm->state == FICL_VM_STATE_COMPILE) { + ficlDictionaryAbortDefinition(dictionary); +#if FICL_WANT_LOCALS + ficlDictionaryEmpty(system->locals, + system->locals->forthWordlist->size); +#endif + } + ficlDictionaryResetSearchOrder(dictionary); + ficlVmReset(vm); + break; + } + + vm->exceptionHandler = oldState; + ficlVmPopTib(vm, &saveficlTIB); + return (except); +} + +/* + * f i c l E x e c X T + * Given a pointer to a ficlWord, push an inner interpreter and + * execute the word to completion. This is in contrast with vmExecute, + * which does not guarantee that the word will have completed when + * the function returns (ie in the case of colon definitions, which + * need an inner interpreter to finish) + * + * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal + * exit condition is VM_INNEREXIT, Ficl's private signal to exit the + * inner loop under normal circumstances. If another code is thrown to + * exit the loop, this function will re-throw it if it's nested under + * itself or ficlExec. + * + * NOTE: this function is intended so that C code can execute ficlWords + * given their address in the dictionary (xt). + */ +int +ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord) +{ + int except; + jmp_buf vmState; + jmp_buf *oldState; + ficlWord *oldRunningWord; + + FICL_VM_ASSERT(vm, vm); + FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord); + + /* + * Save the runningword so that RESTART behaves correctly + * over nested calls. + */ + oldRunningWord = vm->runningWord; + /* + * Save and restore VM's jmp_buf to enable nested calls + */ + oldState = vm->exceptionHandler; + /* This has to come before the setjmp! */ + vm->exceptionHandler = &vmState; + except = setjmp(vmState); + + if (except) + ficlVmPopIP(vm); + else + ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); + + switch (except) { + case 0: + ficlVmExecuteWord(vm, pWord); + ficlVmInnerLoop(vm, 0); + break; + + case FICL_VM_STATUS_INNER_EXIT: + case FICL_VM_STATUS_BREAK: + break; + + case FICL_VM_STATUS_RESTART: + case FICL_VM_STATUS_OUT_OF_TEXT: + case FICL_VM_STATUS_USER_EXIT: + case FICL_VM_STATUS_QUIT: + case FICL_VM_STATUS_ERROR_EXIT: + case FICL_VM_STATUS_ABORT: + case FICL_VM_STATUS_ABORTQ: + default: /* user defined exit code?? */ + if (oldState) { + vm->exceptionHandler = oldState; + ficlVmThrow(vm, except); + } + break; + } + + vm->exceptionHandler = oldState; + vm->runningWord = oldRunningWord; + return (except); +} + +/* + * f i c l P a r s e N u m b e r + * Attempts to convert the NULL terminated string in the VM's pad to + * a number using the VM's current base. If successful, pushes the number + * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE. + * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See + * the standard for DOUBLE wordset. + */ +int +ficlVmParseNumber(ficlVm *vm, ficlString s) +{ + ficlInteger accumulator = 0; + char isNegative = 0; + char isDouble = 0; + unsigned base = vm->base; + char *trace = FICL_STRING_GET_POINTER(s); + ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s); + unsigned c; + unsigned digit; + + if (length > 1) { + switch (*trace) { + case '-': + trace++; + length--; + isNegative = 1; + break; + case '+': + trace++; + length--; + isNegative = 0; + break; + default: + break; + } + } + + /* detect & remove trailing decimal */ + if ((length > 0) && (trace[length - 1] == '.')) { + isDouble = 1; + length--; + } + + if (length == 0) /* detect "+", "-", ".", "+." etc */ + return (0); /* false */ + + while ((length--) && ((c = *trace++) != '\0')) { + if (!isalnum(c)) + return (0); /* false */ + + digit = c - '0'; + + if (digit > 9) + digit = tolower(c) - 'a' + 10; + + if (digit >= base) + return (0); /* false */ + + accumulator = accumulator * base + digit; + } + + if (isNegative) + accumulator = -accumulator; + + ficlStackPushInteger(vm->dataStack, accumulator); + if (vm->state == FICL_VM_STATE_COMPILE) + ficlPrimitiveLiteralIm(vm); + + if (isDouble) { /* simple (required) DOUBLE support */ + if (isNegative) + ficlStackPushInteger(vm->dataStack, -1); + else + ficlStackPushInteger(vm->dataStack, 0); + if (vm->state == FICL_VM_STATE_COMPILE) + ficlPrimitiveLiteralIm(vm); + } + + return (1); /* true */ +} + +/* + * d i c t C h e c k + * Checks the dictionary for corruption and throws appropriate + * errors. + * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot + * -n number of ADDRESS UNITS proposed to de-allot + * 0 just do a consistency check + */ +void +ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) +{ +#if FICL_ROBUST >= 1 + if ((cells >= 0) && + (ficlDictionaryCellsAvailable(dictionary) * + (int)sizeof (ficlCell) < cells)) { + ficlVmThrowError(vm, "Error: dictionary full"); + } + + if ((cells <= 0) && + (ficlDictionaryCellsUsed(dictionary) * + (int)sizeof (ficlCell) < -cells)) { + ficlVmThrowError(vm, "Error: dictionary underflow"); + } +#else /* FICL_ROBUST >= 1 */ + FICL_IGNORE(vm); + FICL_IGNORE(dictionary); + FICL_IGNORE(cells); +#endif /* FICL_ROBUST >= 1 */ +} + +void +ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) +{ +#if FICL_ROBUST >= 1 + ficlVmDictionarySimpleCheck(vm, dictionary, cells); + + if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) { + ficlDictionaryResetSearchOrder(dictionary); + ficlVmThrowError(vm, "Error: search order overflow"); + } else if (dictionary->wordlistCount < 0) { + ficlDictionaryResetSearchOrder(dictionary); + ficlVmThrowError(vm, "Error: search order underflow"); + } +#else /* FICL_ROBUST >= 1 */ + FICL_IGNORE(vm); + FICL_IGNORE(dictionary); + FICL_IGNORE(cells); +#endif /* FICL_ROBUST >= 1 */ +} + +void +ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n) +{ + FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n); + FICL_IGNORE(vm); + ficlDictionaryAllot(dictionary, n); +} + +void +ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells) +{ + FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells); + FICL_IGNORE(vm); + ficlDictionaryAllotCells(dictionary, cells); +} + +/* + * f i c l P a r s e W o r d + * From the standard, section 3.4 + * b) Search the dictionary name space (see 3.4.2). If a definition name + * matching the string is found: + * 1.if interpreting, perform the interpretation semantics of the definition + * (see 3.4.3.2), and continue at a); + * 2.if compiling, perform the compilation semantics of the definition + * (see 3.4.3.3), and continue at a). + * + * c) If a definition name matching the string is not found, attempt to + * convert the string to a number (see 3.4.1.3). If successful: + * 1.if interpreting, place the number on the data stack, and continue at a); + * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place + * the number on the stack (see 6.1.1780 LITERAL), and continue at a); + * + * d) If unsuccessful, an ambiguous condition exists (see 3.4.4). + * + * (jws 4/01) Modified to be a ficlParseStep + */ +int +ficlVmParseWord(ficlVm *vm, ficlString name) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *tempFW; + + FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0); + FICL_STACK_CHECK(vm->dataStack, 0, 0); + +#if FICL_WANT_LOCALS + if (vm->callback.system->localsCount > 0) { + tempFW = ficlSystemLookupLocal(vm->callback.system, name); + } else +#endif + tempFW = ficlDictionaryLookup(dictionary, name); + + if (vm->state == FICL_VM_STATE_INTERPRET) { + if (tempFW != NULL) { + if (ficlWordIsCompileOnly(tempFW)) { + ficlVmThrowError(vm, + "Error: FICL_VM_STATE_COMPILE only!"); + } + + ficlVmExecuteWord(vm, tempFW); + return (1); /* true */ + } + } else { /* (vm->state == FICL_VM_STATE_COMPILE) */ + if (tempFW != NULL) { + if (ficlWordIsImmediate(tempFW)) { + ficlVmExecuteWord(vm, tempFW); + } else { + ficlCell c; + c.p = tempFW; + if (tempFW->flags & FICL_WORD_INSTRUCTION) + ficlDictionaryAppendUnsigned(dictionary, + (ficlInteger)tempFW->code); + else + ficlDictionaryAppendCell(dictionary, c); + } + return (1); /* true */ + } + } + + return (0); /* false */ +} |