/* * 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. */ /* * Copyright 2019 Joyent, Inc. */ #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); /* FALLTHROUGH */ 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) static 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; volatile int count; /* volatile because of longjmp */ 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!"); break; 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; } case ficlInstructionUGreaterThan: CHECK_STACK(2, 1); u = (dataTop--)->u; dataTop->i = FICL_BOOL(dataTop->u > u); 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); } (void) 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 - 1); (void) 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); (void) vsprintf(vm->pad, fmt, list); va_end(list); (void) 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) { (void) vsprintf(vm->pad, fmt, list); /* * well, we can try anyway, we're certainly not * returning to our caller! */ va_end(list); (void) 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 */ }