diff options
Diffstat (limited to 'vm.c')
| -rw-r--r-- | vm.c | 3097 |
1 files changed, 2693 insertions, 404 deletions
@@ -3,14 +3,14 @@ ** Forth Inspired Command Language - virtual machine methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** $Id: vm.c,v 1.12 2001-12-04 17:58:14-08 jsadler Exp jsadler $ +** $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $ *******************************************************************/ /* -** This file implements the virtual machine of FICL. Each virtual +** 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 interp. +** of the interpreter. */ /* ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) @@ -18,9 +18,9 @@ ** ** Get the latest Ficl release at http://ficl.sourceforge.net ** -** I am interested in hearing from anyone who uses ficl. If you have +** 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 +** 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 @@ -54,53 +54,54 @@ #include <ctype.h> #include "ficl.h" -static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - +#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 vmBranchRelative(FICL_VM *pVM, int offset) +void ficlVmBranchRelative(ficlVm *vm, int offset) { - pVM->ip += offset; + vm->ip += offset; return; } /************************************************************************** v m C r e a t e -** Creates a virtual machine either from scratch (if pVM is NULL on entry) +** 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. **************************************************************************/ -FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) +ficlVm *ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack) { - if (pVM == NULL) + if (vm == NULL) { - pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM)); - assert (pVM); - memset(pVM, 0, sizeof (FICL_VM)); + vm = (ficlVm *)ficlMalloc(sizeof (ficlVm)); + FICL_ASSERT(NULL, vm); + memset(vm, 0, sizeof (ficlVm)); } - if (pVM->pStack) - stackDelete(pVM->pStack); - pVM->pStack = stackCreate(nPStack); + if (vm->dataStack) + ficlStackDestroy(vm->dataStack); + vm->dataStack = ficlStackCreate(vm, "data", nPStack); - if (pVM->rStack) - stackDelete(pVM->rStack); - pVM->rStack = stackCreate(nRStack); + if (vm->returnStack) + ficlStackDestroy(vm->returnStack); + vm->returnStack = ficlStackCreate(vm, "return", nRStack); #if FICL_WANT_FLOAT - if (pVM->fStack) - stackDelete(pVM->fStack); - pVM->fStack = stackCreate(nPStack); + if (vm->floatStack) + ficlStackDestroy(vm->floatStack); + vm->floatStack = ficlStackCreate(vm, "float", nPStack); #endif - pVM->textOut = ficlTextOut; - - vmReset(pVM); - return pVM; + ficlVmReset(vm); + return vm; } @@ -109,37 +110,69 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) ** Free all memory allocated to the specified VM and its subordinate ** structures. **************************************************************************/ -void vmDelete (FICL_VM *pVM) +void ficlVmDestroy(ficlVm *vm) { - if (pVM) + if (vm) { - ficlFree(pVM->pStack); - ficlFree(pVM->rStack); + ficlFree(vm->dataStack); + ficlFree(vm->returnStack); #if FICL_WANT_FLOAT - ficlFree(pVM->fStack); + ficlFree(vm->floatStack); #endif - ficlFree(pVM); + ficlFree(vm); } return; } + + /************************************************************************** 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 interp +** colon definition, the definition itself needs the inner interpreter ** to complete. This does not happen until control reaches ficlExec **************************************************************************/ -void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) +void ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord) { - pVM->runningWord = pWord; - pWord->code(pVM); + ficlVmInnerLoop(vm, pWord); return; } + +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 + *(int *)ip; + switch ((ficlInstruction)*destination) + { + case ficlInstructionBranchParenWithCheck: + /* preoptimize where we're jumping to */ + ficlVmOptimizeJumpToJump(vm, destination); + case ficlInstructionBranchParen: + { + destination++; + destination += *(int *)destination; + *ip = (ficlWord *)(destination - ip); + break; + } + } + } + } + /************************************************************************** v m I n n e r L o o p ** the mysterious inner interpreter... @@ -149,131 +182,2177 @@ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) ** 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() -** Visual C++ 5 chokes on this loop in Release mode. Aargh. **************************************************************************/ -#if INLINE_INNER_LOOP == 0 -void vmInnerLoop(FICL_VM *pVM) + + +#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) { - M_INNER_LOOP(pVM); + /* + ** 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 -#if 0 -/* -** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations, -** as well as create does> : ; and various literals -*/ -typedef enum -{ - PATCH = 0, - L0, - L1, - L2, - LMINUS1, - LMINUS2, - DROP, - SWAP, - DUP, - PICK, - ROLL, - FETCH, - STORE, - BRANCH, - CBRANCH, - LEAVE, - TO_R, - R_FROM, - EXIT; -} OPCODE; - -typedef CELL *IPTYPE; - -void vmInnerLoop(FICL_VM *pVM) -{ - IPTYPE ip = pVM->ip; - FICL_STACK *pStack = pVM->pStack; - for (;;) - { - OPCODE o = (*ip++).i; - CELL c; - switch (o) - { - case L0: - stackPushINT(pStack, 0); - break; - case L1: - stackPushINT(pStack, 1); - break; - case L2: - stackPushINT(pStack, 2); - break; - case LMINUS1: - stackPushINT(pStack, -1); - break; - case LMINUS2: - stackPushINT(pStack, -2); - break; - case DROP: - stackDrop(pStack, 1); - break; - case SWAP: - stackRoll(pStack, 1); - break; - case DUP: - stackPick(pStack, 0); - break; - case PICK: - c = *ip++; - stackPick(pStack, c.i); - break; - case ROLL: - c = *ip++; - stackRoll(pStack, c.i); - break; - case EXIT: - return; - } - } +#endif /* FICL_ROBUST <= 1 */ - return; -} +#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; + + LOCAL_VARIABLE_REFILL; + + oldExceptionHandler = vm->exceptionHandler; + vm->exceptionHandler = &exceptionHandler; /* This has to come before the setjmp! */ + except = setjmp(exceptionHandler); + + 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 += *(int *)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 + 1, i + 2); + *dataTop = dataTop[-i]; + 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 = rand(); + continue; + } + + + /************************************************************************** + ** s e e d - r a n d o m + ** Ficl-specific + **************************************************************************/ + case ficlInstructionSeedRandom: + { + srand((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)) + { + returnTop -= 3; /* nuke the loop indices & "leave" addr */ + 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 = (ficlFloat)((dataTop--)->i); + continue; + } + + /******************************************************************* + ** Do float to integer conversion. + ** float>int ( r -- n ) + *******************************************************************/ + case ficlInstructionFloatToInt: + { + CHECK_STACK(0, 1); + CHECK_FLOAT_STACK(1, 0); + + (++dataTop)->i = (ficlInteger)((floatTop--)->f); + 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+1, c.i+2); + + floatTop[1] = floatTop[- c.i]; + 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 < 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 **************************************************************************/ -FICL_DICT *vmGetDict(FICL_VM *pVM) +ficlDictionary *ficlVmGetDictionary(ficlVm *vm) { - assert(pVM); - return pVM->pSys->dp; + 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_STRING_MAX characters to the supplied destination buffer, a -** FICL_STRING. The destination string is NULL terminated. +** 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 *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter) +char *ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter) { - STRINGINFO si = vmParseStringEx(pVM, delimiter, 0); + ficlString s = ficlVmParseStringEx(vm, delimiter, 0); - if (SI_COUNT(si) > FICL_STRING_MAX) + if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) { - SI_SETLEN(si, FICL_STRING_MAX); + FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX); } - strncpy(spDest->text, SI_PTR(si), SI_COUNT(si)); - spDest->text[SI_COUNT(si)] = '\0'; - spDest->count = (FICL_COUNT)SI_COUNT(si); + 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 spDest->text + SI_COUNT(si) + 1; + return counted->text + FICL_STRING_GET_LENGTH(s) + 1; } @@ -282,16 +2361,16 @@ char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter) ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with ** non-zero length. **************************************************************************/ -STRINGINFO vmGetWord(FICL_VM *pVM) +ficlString ficlVmGetWord(ficlVm *vm) { - STRINGINFO si = vmGetWord0(pVM); + ficlString s = ficlVmGetWord0(vm); - if (SI_COUNT(si) == 0) + if (FICL_STRING_GET_LENGTH(s) == 0) { - vmThrow(pVM, VM_RESTART); + ficlVmThrow(vm, FICL_VM_STATUS_RESTART); } - return si; + return s; } @@ -304,44 +2383,38 @@ STRINGINFO vmGetWord(FICL_VM *pVM) ** does not use vmParseString because it uses isspace() rather than a ** single delimiter character. **************************************************************************/ -STRINGINFO vmGetWord0(FICL_VM *pVM) +ficlString ficlVmGetWord0(ficlVm *vm) { - char *pSrc = vmGetInBuf(pVM); - char *pEnd = vmGetInBufEnd(pVM); - STRINGINFO si; - FICL_UNS count = 0; - char ch = 0; + char *trace = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + ficlString s; + ficlUnsigned length = 0; + char c = 0; - pSrc = skipSpace(pSrc, pEnd); - SI_SETPTR(si, pSrc); + trace = ficlStringSkipSpace(trace, stop); + FICL_STRING_SET_POINTER(s, trace); -/* - for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc) - { - count++; - } -*/ - /* Changed to make Purify happier. --lch */ + /* Please leave this loop this way; it makes Purify happier. --lch */ for (;;) { - if (pEnd == pSrc) - break; - ch = *pSrc; - if (isspace(ch)) - break; - count++; - pSrc++; + if (trace == stop) + break; + c = *trace; + if (isspace((unsigned char)c)) + break; + length++; + trace++; } - SI_SETLEN(si, count); + FICL_STRING_SET_LENGTH(s, length); - if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */ - pSrc++; + if ((trace != stop) && isspace((unsigned char)c)) /* skip one trailing delimiter */ + trace++; - vmUpdateTib(pVM, pSrc); + ficlVmUpdateTib(vm, trace); - return si; + return s; } @@ -351,18 +2424,18 @@ STRINGINFO vmGetWord0(FICL_VM *pVM) ** string. Returns the length of the string. If the string is too long ** to fit in the pad, it is truncated. **************************************************************************/ -int vmGetWordToPad(FICL_VM *pVM) +int ficlVmGetWordToPad(ficlVm *vm) { - STRINGINFO si; - char *cp = (char *)pVM->pad; - si = vmGetWord(pVM); + ficlString s; + char *pad = (char *)vm->pad; + s = ficlVmGetWord(vm); - if (SI_COUNT(si) > nPAD) - SI_SETLEN(si, nPAD); + if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE) + FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE); - strncpy(cp, SI_PTR(si), SI_COUNT(si)); - cp[SI_COUNT(si)] = '\0'; - return (int)(SI_COUNT(si)); + 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)); } @@ -376,42 +2449,42 @@ int vmGetWordToPad(FICL_VM *pVM) ** Returns the address and length of the parsed string, not including the ** trailing delimiter. **************************************************************************/ -STRINGINFO vmParseString(FICL_VM *pVM, char delim) +ficlString ficlVmParseString(ficlVm *vm, char delimiter) { - return vmParseStringEx(pVM, delim, 1); + return ficlVmParseStringEx(vm, delimiter, 1); } -STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) +ficlString ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters) { - STRINGINFO si; - char *pSrc = vmGetInBuf(pVM); - char *pEnd = vmGetInBufEnd(pVM); - char ch; + ficlString s; + char *trace = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + char c; - if (fSkipLeading) - { /* skip lead delimiters */ - while ((pSrc != pEnd) && (*pSrc == delim)) - pSrc++; + if (skipLeadingDelimiters) + { + while ((trace != stop) && (*trace == delimiter)) + trace++; } - SI_SETPTR(si, pSrc); /* mark start of text */ + FICL_STRING_SET_POINTER(s, trace); /* mark start of text */ - for (ch = *pSrc; (pSrc != pEnd) - && (ch != delim) - && (ch != '\r') - && (ch != '\n'); ch = *++pSrc) + for (c = *trace; + (trace != stop) && (c != delimiter) + && (c != '\r') && (c != '\n'); + c = *++trace) { ; /* find next delimiter or end of line */ } /* set length of result */ - SI_SETLEN(si, pSrc - SI_PTR(si)); + FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s)); - if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ - pSrc++; + if ((trace != stop) && (*trace == delimiter)) /* gobble trailing delimiter */ + trace++; - vmUpdateTib(pVM, pSrc); - return si; + ficlVmUpdateTib(vm, trace); + return s; } @@ -419,9 +2492,9 @@ STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) v m P o p ** **************************************************************************/ -CELL vmPop(FICL_VM *pVM) +ficlCell ficlVmPop(ficlVm *vm) { - return stackPop(pVM->pStack); + return ficlStackPop(vm->dataStack); } @@ -429,9 +2502,9 @@ CELL vmPop(FICL_VM *pVM) v m P u s h ** **************************************************************************/ -void vmPush(FICL_VM *pVM, CELL c) +void ficlVmPush(ficlVm *vm, ficlCell c) { - stackPush(pVM->pStack, c); + ficlStackPush(vm->dataStack, c); return; } @@ -440,9 +2513,9 @@ void vmPush(FICL_VM *pVM, CELL c) v m P o p I P ** **************************************************************************/ -void vmPopIP(FICL_VM *pVM) +void ficlVmPopIP(ficlVm *vm) { - pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack)); + vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack)); return; } @@ -451,10 +2524,10 @@ void vmPopIP(FICL_VM *pVM) v m P u s h I P ** **************************************************************************/ -void vmPushIP(FICL_VM *pVM, IPTYPE newIP) +void ficlVmPushIP(ficlVm *vm, ficlIp newIP) { - stackPushPtr(pVM->rStack, (void *)pVM->ip); - pVM->ip = newIP; + ficlStackPushPointer(vm->returnStack, (void *)vm->ip); + vm->ip = newIP; return; } @@ -463,24 +2536,24 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP) v m P u s h T i b ** Binds the specified input string to the VM and clears >IN (the index) **************************************************************************/ -void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib) +void ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib) { if (pSaveTib) { - *pSaveTib = pVM->tib; + *pSaveTib = vm->tib; } - pVM->tib.cp = text; - pVM->tib.end = text + nChars; - pVM->tib.index = 0; + vm->tib.text = text; + vm->tib.end = text + nChars; + vm->tib.index = 0; } -void vmPopTib(FICL_VM *pVM, TIB *pTib) +void ficlVmPopTib(ficlVm *vm, ficlTIB *pTib) { if (pTib) { - pVM->tib = *pTib; + vm->tib = *pTib; } return; } @@ -490,18 +2563,18 @@ void vmPopTib(FICL_VM *pVM, TIB *pTib) v m Q u i t ** **************************************************************************/ -void vmQuit(FICL_VM *pVM) -{ - stackReset(pVM->rStack); - pVM->fRestart = 0; - pVM->ip = NULL; - pVM->runningWord = NULL; - pVM->state = INTERPRET; - pVM->tib.cp = NULL; - pVM->tib.end = NULL; - pVM->tib.index = 0; - pVM->pad[0] = '\0'; - pVM->sourceID.i = 0; +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; return; } @@ -510,14 +2583,14 @@ void vmQuit(FICL_VM *pVM) v m R e s e t ** **************************************************************************/ -void vmReset(FICL_VM *pVM) +void ficlVmReset(ficlVm *vm) { - vmQuit(pVM); - stackReset(pVM->pStack); + ficlVmQuit(vm); + ficlStackReset(vm->dataStack); #if FICL_WANT_FLOAT - stackReset(pVM->fStack); + ficlStackReset(vm->floatStack); #endif - pVM->base = 10; + vm->base = 10; return; } @@ -527,273 +2600,489 @@ void vmReset(FICL_VM *pVM) ** Binds the specified output callback to the vm. If you pass NULL, ** binds the default output function (ficlTextOut) **************************************************************************/ -void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut) +void ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut) { - if (textOut) - pVM->textOut = textOut; - else - pVM->textOut = ficlTextOut; - + vm->callback.textOut = textOut; return; } -/************************************************************************** - v m T e x t O u t -** Feeds text to the vm's output callback -**************************************************************************/ -void vmTextOut(FICL_VM *pVM, char *text, int fNewline) -{ - assert(pVM); - assert(pVM->textOut); - (pVM->textOut)(pVM, text, fNewline); +void ficlVmTextOut(ficlVm *vm, char *text) + { + ficlCallbackTextOut((ficlCallback *)vm, text); + } - return; -} +void ficlVmErrorOut(ficlVm *vm, char *text) + { + ficlCallbackErrorOut((ficlCallback *)vm, text); + } -/************************************************************************** + + /************************************************************************** v m T h r o w ** **************************************************************************/ -void vmThrow(FICL_VM *pVM, int except) +void ficlVmThrow(ficlVm *vm, int except) { - if (pVM->pState) - longjmp(*(pVM->pState), except); + if (vm->exceptionHandler) + longjmp(*(vm->exceptionHandler), except); } -void vmThrowErr(FICL_VM *pVM, char *fmt, ...) +void ficlVmThrowError(ficlVm *vm, char *fmt, ...) { - va_list va; - va_start(va, fmt); - vsprintf(pVM->pad, fmt, va); - vmTextOut(pVM, pVM->pad, 1); - va_end(va); - longjmp(*(pVM->pState), VM_ERREXIT); + 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); } -/************************************************************************** - w o r d I s I m m e d i a t e -** -**************************************************************************/ -int wordIsImmediate(FICL_WORD *pFW) +void ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list) { - return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE)); + 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); } /************************************************************************** - w o r d I s C o m p i l e O n l y -** + f i c l E v a l u a t e +** Wrapper for ficlExec() which sets SOURCE-ID to -1. **************************************************************************/ -int wordIsCompileOnly(FICL_WORD *pFW) +int ficlVmEvaluate(ficlVm *vm, char *s) { - return ((pFW != NULL) && (pFW->flags & FW_COMPILE)); + 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; } /************************************************************************** - s t r r e v -** + 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. **************************************************************************/ -char *strrev( char *string ) -{ /* reverse a string in-place */ - int i = strlen(string); - char *p1 = string; /* first char of string */ - char *p2 = string + i - 1; /* last non-NULL char of string */ - char c; +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; + vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */ + except = setjmp(vmState); - if (i > 1) + switch (except) { - while (p1 < p2) + case 0: + if (vm->restart) { - c = *p2; - *p2 = *p1; - *p1 = c; - p1++; p2--; + vm->runningWord->code(vm); + vm->restart = 0; + } + else + { /* set VM up to interpret text */ + ficlVmPushIP(vm, &(system->interpreterLoop[0])); } - } - - return string; -} + ficlVmInnerLoop(vm, 0); + break; -/************************************************************************** - d i g i t _ t o _ c h a r -** -**************************************************************************/ -char digit_to_char(int value) -{ - return digits[value]; + 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 ((vm->state != FICL_VM_STATE_COMPILE) && (vm->sourceId.i == 0)) + ficlVmTextOut(vm, FICL_PROMPT); + 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); } /************************************************************************** - i s P o w e r O f T w o -** Tests whether supplied argument is an integer power of 2 (2**n) -** where 32 > n > 1, and returns n if so. Otherwise returns zero. + 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 isPowerOfTwo(FICL_UNS u) +int ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord) { - int i = 1; - FICL_UNS t = 2; + 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; + vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */ + except = setjmp(vmState); + + if (except) + ficlVmPopIP(vm); + else + ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); - for (; ((t <= u) && (t != 0)); i++, t <<= 1) + switch (except) { - if (u == t) - return i; + 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; } - return 0; + vm->exceptionHandler = oldState; + vm->runningWord = oldRunningWord; + return (except); } /************************************************************************** - l t o a -** + 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. **************************************************************************/ -char *ltoa( FICL_INT value, char *string, int radix ) -{ /* convert long to string, any base */ - char *cp = string; - int sign = ((radix == 10) && (value < 0)); - int pwr; - - assert(radix > 1); - assert(radix < 37); - assert(string); - - pwr = isPowerOfTwo((FICL_UNS)radix); - if (sign) - value = -value; - - if (value == 0) - *cp++ = '0'; - else if (pwr != 0) +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) { - FICL_UNS v = (FICL_UNS) value; - FICL_UNS mask = (FICL_UNS) ~(-1 << pwr); - while (v) + switch (*trace) { - *cp++ = digits[v & mask]; - v >>= pwr; + case '-': + trace++; + length--; + isNegative = 1; + break; + case '+': + trace++; + length--; + isNegative = 0; + break; + default: + break; } } - else + + if ((length > 0) && (trace[length - 1] == '.')) /* detect & remove trailing decimal */ { - UNSQR result; - DPUNS v; - v.hi = 0; - v.lo = (FICL_UNS)value; - while (v.lo) - { - result = ficlLongDiv(v, (FICL_UNS)radix); - *cp++ = digits[result.rem]; - v.lo = result.quot; - } + isDouble = 1; + length--; } - if (sign) - *cp++ = '-'; + if (length == 0) /* detect "+", "-", ".", "+." etc */ + return 0; /* false */ - *cp++ = '\0'; + while ((length--) && ((c = *trace++) != '\0')) + { + if (!isalnum(c)) + return 0; /* false */ - return strrev(string); -} + digit = c - '0'; + if (digit > 9) + digit = tolower(c) - 'a' + 10; -/************************************************************************** - u l t o a -** -**************************************************************************/ -char *ultoa(FICL_UNS value, char *string, int radix ) -{ /* convert long to string, any base */ - char *cp = string; - DPUNS ud; - UNSQR result; - - assert(radix > 1); - assert(radix < 37); - assert(string); - - if (value == 0) - *cp++ = '0'; - else - { - ud.hi = 0; - ud.lo = value; - result.quot = value; + if (digit >= base) + return 0; /* false */ - while (ud.lo) - { - result = ficlLongDiv(ud, (FICL_UNS)radix); - ud.lo = result.quot; - *cp++ = digits[result.rem]; - } + accumulator = accumulator * base + digit; } - *cp++ = '\0'; + if (isDouble) /* simple (required) DOUBLE support */ + ficlStackPushInteger(vm->dataStack, 0); - return strrev(string); + if (isNegative) + accumulator = -accumulator; + + ficlStackPushInteger(vm->dataStack, accumulator); + if (vm->state == FICL_VM_STATE_COMPILE) + ficlPrimitiveLiteralIm(vm); + + return 1; /* true */ } + + + /************************************************************************** - c a s e F o l d -** Case folds a NULL terminated string in place. All characters -** get converted to lower case. + 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 **************************************************************************/ -char *caseFold(char *cp) +void ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) +#if FICL_ROBUST >= 1 { - char *oldCp = cp; + if ((cells >= 0) && (ficlDictionaryCellsAvailable(dictionary) * (int)sizeof(ficlCell) < cells)) + { + ficlVmThrowError(vm, "Error: dictionary full"); + } - while (*cp) + if ((cells <= 0) && (ficlDictionaryCellsUsed(dictionary) * (int)sizeof(ficlCell) < -cells)) { - if (isupper(*cp)) - *cp = (char)tolower(*cp); - cp++; + ficlVmThrowError(vm, "Error: dictionary underflow"); } - return oldCp; + return; } +#else /* FICL_ROBUST >= 1 */ +{ + FICL_IGNORE(vm); + FICL_IGNORE(dictionary); + FICL_IGNORE(cells); +} +#endif /* FICL_ROBUST >= 1 */ -/************************************************************************** - s t r i n c m p -** (jws) simplified the code a bit in hopes of appeasing Purify -**************************************************************************/ -int strincmp(char *cp1, char *cp2, FICL_UNS count) +void ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells) +#if FICL_ROBUST >= 1 { - int i = 0; + ficlVmDictionarySimpleCheck(vm, dictionary, cells); - for (; 0 < count; ++cp1, ++cp2, --count) + if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) + { + ficlDictionaryResetSearchOrder(dictionary); + ficlVmThrowError(vm, "Error: search order overflow"); + } + else if (dictionary->wordlistCount < 0) { - i = tolower(*cp1) - tolower(*cp2); - if (i != 0) - return i; - else if (*cp1 == '\0') - return 0; + ficlDictionaryResetSearchOrder(dictionary); + ficlVmThrowError(vm, "Error: search order underflow"); } - return 0; + + return; +} +#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); } + /************************************************************************** - s k i p S p a c e -** Given a string pointer, returns a pointer to the first non-space -** char of the string, or to the NULL terminator if no such char found. -** If the pointer reaches "end" first, stop there. Pass NULL to -** suppress this behavior. + 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 **************************************************************************/ -char *skipSpace(char *cp, char *end) +int ficlVmParseWord(ficlVm *vm, ficlString name) { - assert(cp); + 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); - while ((cp != end) && isspace(*cp)) - cp++; + 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 + { + if (tempFW->flags & FICL_WORD_INSTRUCTION) + ficlDictionaryAppendUnsigned(dictionary, (ficlInteger)tempFW->code); + else + ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(tempFW)); + } + return 1; /* true */ + } + } - return cp; + return 0; /* false */ } |