diff options
Diffstat (limited to 'usr/src/common/ficl/primitives.c')
| -rw-r--r-- | usr/src/common/ficl/primitives.c | 3496 |
1 files changed, 3496 insertions, 0 deletions
diff --git a/usr/src/common/ficl/primitives.c b/usr/src/common/ficl/primitives.c new file mode 100644 index 0000000000..c8b9829705 --- /dev/null +++ b/usr/src/common/ficl/primitives.c @@ -0,0 +1,3496 @@ +/* + * w o r d s . c + * Forth Inspired Command Language + * ANS Forth CORE word-set written in C + * Author: John Sadler (john_sadler@alum.mit.edu) + * Created: 19 July 1997 + * $Id: primitives.c,v 1.4 2010/09/13 18:43:04 asau Exp $ + */ +/* + * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) + * All rights reserved. + * + * Get the latest Ficl release at http://ficl.sourceforge.net + * + * I am interested in hearing from anyone who uses Ficl. If you have + * a problem, a success story, a defect, an enhancement request, or + * if you would like to contribute to the Ficl release, please + * contact me by email at the address above. + * + * L I C E N S E and D I S C L A I M E R + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "ficl.h" +#include <limits.h> + +/* + * Control structure building words use these + * strings' addresses as markers on the stack to + * check for structure completion. + */ +static char doTag[] = "do"; +static char colonTag[] = "colon"; +static char leaveTag[] = "leave"; + +static char destTag[] = "target"; +static char origTag[] = "origin"; + +static char caseTag[] = "case"; +static char ofTag[] = "of"; +static char fallthroughTag[] = "fallthrough"; + +/* + * C O N T R O L S T R U C T U R E B U I L D E R S + * + * Push current dictionary location for later branch resolution. + * The location may be either a branch target or a patch address... + */ +static void +markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) +{ + ficlStackPushPointer(vm->dataStack, dictionary->here); + ficlStackPushPointer(vm->dataStack, tag); +} + +static void +markControlTag(ficlVm *vm, char *tag) +{ + ficlStackPushPointer(vm->dataStack, tag); +} + +static void +matchControlTag(ficlVm *vm, char *wantTag) +{ + char *tag; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + tag = (char *)ficlStackPopPointer(vm->dataStack); + + /* + * Changed the code below to compare the pointers first + * (by popular demand) + */ + if ((tag != wantTag) && strcmp(tag, wantTag)) { + ficlVmThrowError(vm, + "Error -- unmatched control structure \"%s\"", wantTag); + } +} + +/* + * Expect a branch target address on the param stack, + * FICL_VM_STATE_COMPILE a literal offset from the current dictionary location + * to the target address + */ +static void +resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) +{ + ficlCell *patchAddr, c; + + matchControlTag(vm, tag); + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + c.i = patchAddr - dictionary->here; + + ficlDictionaryAppendCell(dictionary, c); +} + +/* + * Expect a branch patch address on the param stack, + * FICL_VM_STATE_COMPILE a literal offset from the patch location + * to the current dictionary location + */ +static void +resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) +{ + ficlInteger offset; + ficlCell *patchAddr; + + matchControlTag(vm, tag); + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + offset = dictionary->here - patchAddr; + (*patchAddr).i = offset; +} + +/* + * Match the tag to the top of the stack. If success, + * sopy "here" address into the ficlCell whose address is next + * on the stack. Used by do..leave..loop. + */ +static void +resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag) +{ + ficlCell *patchAddr; + char *tag; + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + tag = ficlStackPopPointer(vm->dataStack); + + /* + * Changed the comparison below to compare the pointers first + * (by popular demand) + */ + if ((tag != wantTag) && strcmp(tag, wantTag)) { + ficlVmTextOut(vm, "Warning -- Unmatched control word: "); + ficlVmTextOut(vm, wantTag); + ficlVmTextOut(vm, "\n"); + } + + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + (*patchAddr).p = dictionary->here; +} + +/* + * c o l o n d e f i n i t i o n s + * Code to begin compiling a colon definition + * This function sets the state to FICL_VM_STATE_COMPILE, then creates a + * new word whose name is the next word in the input stream + * and whose code is colonParen. + */ +static void +ficlPrimitiveColon(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + vm->state = FICL_VM_STATE_COMPILE; + markControlTag(vm, colonTag); + ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionColonParen, + FICL_WORD_DEFAULT | FICL_WORD_SMUDGED); + +#if FICL_WANT_LOCALS + vm->callback.system->localsCount = 0; +#endif +} + +static void +ficlPrimitiveSemicolonCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + matchControlTag(vm, colonTag); + +#if FICL_WANT_LOCALS + if (vm->callback.system->localsCount > 0) { + ficlDictionary *locals; + locals = ficlSystemGetLocals(vm->callback.system); + ficlDictionaryEmpty(locals, locals->forthWordlist->size); + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionUnlinkParen); + } + vm->callback.system->localsCount = 0; +#endif + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen); + vm->state = FICL_VM_STATE_INTERPRET; + ficlDictionaryUnsmudge(dictionary); +} + +/* + * e x i t + * CORE + * 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". + */ +static void +ficlPrimitiveExitCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + FICL_IGNORE(vm); + +#if FICL_WANT_LOCALS + if (vm->callback.system->localsCount > 0) { + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionUnlinkParen); + } +#endif + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen); +} + +/* + * c o n s t a n t + * IMMEDIATE + * Compiles a constant into the dictionary. Constants return their + * value when invoked. Expects a value on top of the parm stack. + */ +static void +ficlPrimitiveConstant(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + ficlDictionaryAppendConstantInstruction(dictionary, name, + ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack)); +} + +static void +ficlPrimitive2Constant(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + ficlDictionaryAppend2ConstantInstruction(dictionary, name, + ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack)); +} + +/* + * d i s p l a y C e l l + * Drop and print the contents of the ficlCell at the top of the param + * stack + */ +static void +ficlPrimitiveDot(ficlVm *vm) +{ + ficlCell c; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + c = ficlStackPop(vm->dataStack); + ficlLtoa((c).i, vm->pad, vm->base); + strcat(vm->pad, " "); + ficlVmTextOut(vm, vm->pad); +} + +static void +ficlPrimitiveUDot(ficlVm *vm) +{ + ficlUnsigned u; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + u = ficlStackPopUnsigned(vm->dataStack); + ficlUltoa(u, vm->pad, vm->base); + strcat(vm->pad, " "); + ficlVmTextOut(vm, vm->pad); +} + +static void +ficlPrimitiveHexDot(ficlVm *vm) +{ + ficlUnsigned u; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + u = ficlStackPopUnsigned(vm->dataStack); + ficlUltoa(u, vm->pad, 16); + strcat(vm->pad, " "); + ficlVmTextOut(vm, vm->pad); +} + +/* + * s t r l e n + * Ficl ( c-string -- length ) + * + * Returns the length of a C-style (zero-terminated) string. + * + * --lch + */ +static void +ficlPrimitiveStrlen(ficlVm *vm) +{ + char *address = (char *)ficlStackPopPointer(vm->dataStack); + ficlStackPushInteger(vm->dataStack, strlen(address)); +} + +/* + * s p r i n t f + * Ficl ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- + * c-addr-buffer u-written success-flag ) + * Similar to the C sprintf() function. It formats into a buffer based on + * a "format" string. Each character in the format string is copied verbatim + * to the output buffer, until SPRINTF encounters a percent sign ("%"). + * SPRINTF then skips the percent sign, and examines the next character + * (the "format character"). Here are the valid format characters: + * s - read a C-ADDR U-LENGTH string from the stack and copy it to + * the buffer + * d - read a ficlCell from the stack, format it as a string (base-10, + * signed), and copy it to the buffer + * x - same as d, except in base-16 + * u - same as d, but unsigned + * % - output a literal percent-sign to the buffer + * SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes + * written, and a flag indicating whether or not it ran out of space while + * writing to the output buffer (FICL_TRUE if it ran out of space). + * + * If SPRINTF runs out of space in the buffer to store the formatted string, + * it still continues parsing, in an effort to preserve your stack (otherwise + * it might leave uneaten arguments behind). + * + * --lch + */ +static void +ficlPrimitiveSprintf(ficlVm *vm) +{ + int bufferLength = ficlStackPopInteger(vm->dataStack); + char *buffer = (char *)ficlStackPopPointer(vm->dataStack); + char *bufferStart = buffer; + + int formatLength = ficlStackPopInteger(vm->dataStack); + char *format = (char *)ficlStackPopPointer(vm->dataStack); + char *formatStop = format + formatLength; + + int base = 10; + int unsignedInteger = 0; /* false */ + + int append = 1; /* true */ + + while (format < formatStop) { + char scratch[64]; + char *source; + int actualLength; + int desiredLength; + int leadingZeroes; + + if (*format != '%') { + source = format; + actualLength = desiredLength = 1; + leadingZeroes = 0; + } else { + format++; + if (format == formatStop) + break; + + leadingZeroes = (*format == '0'); + if (leadingZeroes) { + format++; + if (format == formatStop) + break; + } + + desiredLength = isdigit((unsigned char)*format); + if (desiredLength) { + desiredLength = strtoul(format, &format, 10); + if (format == formatStop) + break; + } else if (*format == '*') { + desiredLength = + ficlStackPopInteger(vm->dataStack); + + format++; + if (format == formatStop) + break; + } + + switch (*format) { + case 's': + case 'S': + actualLength = + ficlStackPopInteger(vm->dataStack); + source = (char *) + ficlStackPopPointer(vm->dataStack); + break; + case 'x': + case 'X': + base = 16; + case 'u': + case 'U': + unsignedInteger = 1; /* true */ + case 'd': + case 'D': { + int integer; + integer = ficlStackPopInteger(vm->dataStack); + if (unsignedInteger) + ficlUltoa(integer, scratch, base); + else + ficlLtoa(integer, scratch, base); + base = 10; + unsignedInteger = 0; /* false */ + source = scratch; + actualLength = strlen(scratch); + break; + } + case '%': + source = format; + actualLength = 1; + default: + continue; + } + } + + if (append) { + if (!desiredLength) + desiredLength = actualLength; + if (desiredLength > bufferLength) { + append = 0; /* false */ + desiredLength = bufferLength; + } + while (desiredLength > actualLength) { + *buffer++ = (char)((leadingZeroes) ? '0' : ' '); + bufferLength--; + desiredLength--; + } + memcpy(buffer, source, actualLength); + buffer += actualLength; + bufferLength -= actualLength; + } + + format++; + } + + ficlStackPushPointer(vm->dataStack, bufferStart); + ficlStackPushInteger(vm->dataStack, buffer - bufferStart); + ficlStackPushInteger(vm->dataStack, FICL_BOOL(!append)); +} + +/* + * d u p & f r i e n d s + */ +static void +ficlPrimitiveDepth(ficlVm *vm) +{ + int i; + + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + i = ficlStackDepth(vm->dataStack); + ficlStackPushInteger(vm->dataStack, i); +} + +/* + * e m i t & f r i e n d s + */ +static void +ficlPrimitiveEmit(ficlVm *vm) +{ + char buffer[2]; + int i; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + i = ficlStackPopInteger(vm->dataStack); + buffer[0] = (char)i; + buffer[1] = '\0'; + ficlVmTextOut(vm, buffer); +} + +static void +ficlPrimitiveCR(ficlVm *vm) +{ + ficlVmTextOut(vm, "\n"); +} + +static void +ficlPrimitiveBackslash(ficlVm *vm) +{ + char *trace = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + char c = *trace; + + while ((trace != stop) && (c != '\r') && (c != '\n')) { + c = *++trace; + } + + /* + * Cope with DOS or UNIX-style EOLs - + * Check for /r, /n, /r/n, or /n/r end-of-line sequences, + * and point trace to next char. If EOL is \0, we're done. + */ + if (trace != stop) { + trace++; + + if ((trace != stop) && (c != *trace) && + ((*trace == '\r') || (*trace == '\n'))) + trace++; + } + + ficlVmUpdateTib(vm, trace); +} + +/* + * paren CORE + * Compilation: Perform the execution semantics given below. + * Execution: ( "ccc<paren>" -- ) + * Parse ccc delimited by ) (right parenthesis). ( is an immediate word. + * The number of characters in ccc may be zero to the number of characters + * in the parse area. + */ +static void +ficlPrimitiveParenthesis(ficlVm *vm) +{ + ficlVmParseStringEx(vm, ')', 0); +} + +/* + * F E T C H & S T O R E + */ + +/* + * i f C o I m + * IMMEDIATE + * Compiles code for a conditional branch into the dictionary + * and pushes the branch patch address on the stack for later + * patching by ELSE or THEN/ENDIF. + */ +static void +ficlPrimitiveIfCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranch0ParenWithCheck); + markBranch(dictionary, vm, origTag); + ficlDictionaryAppendUnsigned(dictionary, 1); +} + +/* + * e l s e C o I m + * + * IMMEDIATE -- compiles an "else"... + * 1) FICL_VM_STATE_COMPILE a branch and a patch address; + * the address gets patched + * by "endif" to point past the "else" code. + * 2) Pop the the "if" patch address + * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE + * address. + * 4) Push the "else" patch address. ("endif" patches this to jump past + * the "else" code. + */ +static void +ficlPrimitiveElseCoIm(ficlVm *vm) +{ + ficlCell *patchAddr; + ficlInteger offset; + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + /* (1) FICL_VM_STATE_COMPILE branch runtime */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranchParenWithCheck); + + matchControlTag(vm, origTag); + /* (2) pop "if" patch addr */ + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + markBranch(dictionary, vm, origTag); /* (4) push "else" patch addr */ + + /* (1) FICL_VM_STATE_COMPILE patch placeholder */ + ficlDictionaryAppendUnsigned(dictionary, 1); + offset = dictionary->here - patchAddr; + (*patchAddr).i = offset; /* (3) Patch "if" */ +} + +/* + * e n d i f C o I m + */ +static void +ficlPrimitiveEndifCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + resolveForwardBranch(dictionary, vm, origTag); +} + +/* + * c a s e C o I m + * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY + * + * + * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks + * like this: + * i*addr i caseTag + * and an OF-SYS (see DPANS94 6.2.1950) looks like this: + * i*addr i caseTag addr ofTag + * The integer under caseTag is the count of fixup addresses that branch + * to ENDCASE. + */ +static void +ficlPrimitiveCaseCoIm(ficlVm *vm) +{ + FICL_STACK_CHECK(vm->dataStack, 0, 2); + + ficlStackPushUnsigned(vm->dataStack, 0); + markControlTag(vm, caseTag); +} + +/* + * e n d c a s eC o I m + * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY + */ +static void +ficlPrimitiveEndcaseCoIm(ficlVm *vm) +{ + ficlUnsigned fixupCount; + ficlDictionary *dictionary; + ficlCell *patchAddr; + ficlInteger offset; + + /* + * if the last OF ended with FALLTHROUGH, + * just add the FALLTHROUGH fixup to the + * ENDOF fixups + */ + if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) { + matchControlTag(vm, fallthroughTag); + patchAddr = ficlStackPopPointer(vm->dataStack); + matchControlTag(vm, caseTag); + fixupCount = ficlStackPopUnsigned(vm->dataStack); + ficlStackPushPointer(vm->dataStack, patchAddr); + ficlStackPushUnsigned(vm->dataStack, fixupCount + 1); + markControlTag(vm, caseTag); + } + + matchControlTag(vm, caseTag); + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + fixupCount = ficlStackPopUnsigned(vm->dataStack); + FICL_STACK_CHECK(vm->dataStack, fixupCount, 0); + + dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop); + + while (fixupCount--) { + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + offset = dictionary->here - patchAddr; + (*patchAddr).i = offset; + } +} + +/* + * o f C o I m + * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY + */ +static void +ficlPrimitiveOfCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlCell *fallthroughFixup = NULL; + + FICL_STACK_CHECK(vm->dataStack, 1, 3); + + if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) { + matchControlTag(vm, fallthroughTag); + fallthroughFixup = ficlStackPopPointer(vm->dataStack); + } + + matchControlTag(vm, caseTag); + + markControlTag(vm, caseTag); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen); + markBranch(dictionary, vm, ofTag); + ficlDictionaryAppendUnsigned(dictionary, 2); + + if (fallthroughFixup != NULL) { + ficlInteger offset = dictionary->here - fallthroughFixup; + (*fallthroughFixup).i = offset; + } +} + +/* + * e n d o f C o I m + * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY + */ +static void +ficlPrimitiveEndofCoIm(ficlVm *vm) +{ + ficlCell *patchAddr; + ficlUnsigned fixupCount; + ficlInteger offset; + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + FICL_STACK_CHECK(vm->dataStack, 4, 3); + + /* ensure we're in an OF, */ + matchControlTag(vm, ofTag); + + /* grab the address of the branch location after the OF */ + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + /* ensure we're also in a "case" */ + matchControlTag(vm, caseTag); + /* grab the current number of ENDOF fixups */ + fixupCount = ficlStackPopUnsigned(vm->dataStack); + + /* FICL_VM_STATE_COMPILE branch runtime */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranchParenWithCheck); + + /* + * push a new ENDOF fixup, the updated count of ENDOF fixups, + * and the caseTag + */ + ficlStackPushPointer(vm->dataStack, dictionary->here); + ficlStackPushUnsigned(vm->dataStack, fixupCount + 1); + markControlTag(vm, caseTag); + + /* reserve space for the ENDOF fixup */ + ficlDictionaryAppendUnsigned(dictionary, 2); + + /* and patch the original OF */ + offset = dictionary->here - patchAddr; + (*patchAddr).i = offset; +} + +/* + * f a l l t h r o u g h C o I m + * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY + */ +static void +ficlPrimitiveFallthroughCoIm(ficlVm *vm) +{ + ficlCell *patchAddr; + ficlInteger offset; + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + FICL_STACK_CHECK(vm->dataStack, 4, 3); + + /* ensure we're in an OF, */ + matchControlTag(vm, ofTag); + /* grab the address of the branch location after the OF */ + patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); + /* ensure we're also in a "case" */ + matchControlTag(vm, caseTag); + + /* okay, here we go. put the case tag back. */ + markControlTag(vm, caseTag); + + /* FICL_VM_STATE_COMPILE branch runtime */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranchParenWithCheck); + + /* push a new FALLTHROUGH fixup and the fallthroughTag */ + ficlStackPushPointer(vm->dataStack, dictionary->here); + markControlTag(vm, fallthroughTag); + + /* reserve space for the FALLTHROUGH fixup */ + ficlDictionaryAppendUnsigned(dictionary, 2); + + /* and patch the original OF */ + offset = dictionary->here - patchAddr; + (*patchAddr).i = offset; +} + +/* + * h a s h + * hash ( c-addr u -- code) + * calculates hashcode of specified string and leaves it on the stack + */ +static void +ficlPrimitiveHash(ficlVm *vm) +{ + ficlString s; + + FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack)); + FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack)); + ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s)); +} + +/* + * i n t e r p r e t + * This is the "user interface" of a Forth. It does the following: + * while there are words in the VM's Text Input Buffer + * Copy next word into the pad (ficlVmGetWord) + * Attempt to find the word in the dictionary (ficlDictionaryLookup) + * If successful, execute the word. + * Otherwise, attempt to convert the word to a number (isNumber) + * If successful, push the number onto the parameter stack. + * Otherwise, print an error message and exit loop... + * End Loop + * + * From the standard, section 3.4 + * Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall + * repeat the following steps until either the parse area is empty or an + * ambiguous condition exists: + * a) Skip leading spaces and parse a name (see 3.4.1); + */ +static void +ficlPrimitiveInterpret(ficlVm *vm) +{ + ficlString s; + int i; + ficlSystem *system; + + FICL_VM_ASSERT(vm, vm); + + system = vm->callback.system; + s = ficlVmGetWord0(vm); + + /* + * Get next word...if out of text, we're done. + */ + if (s.length == 0) { + ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT); + } + + /* + * Run the parse chain against the incoming token until somebody + * eats it. Otherwise emit an error message and give up. + */ + for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) { + ficlWord *word = system->parseList[i]; + + if (word == NULL) + break; + + if (word->code == ficlPrimitiveParseStepParen) { + ficlParseStep pStep; + pStep = (ficlParseStep)(word->param->fn); + if ((*pStep)(vm, s)) + return; + } else { + ficlStackPushPointer(vm->dataStack, + FICL_STRING_GET_POINTER(s)); + ficlStackPushUnsigned(vm->dataStack, + FICL_STRING_GET_LENGTH(s)); + ficlVmExecuteXT(vm, word); + if (ficlStackPopInteger(vm->dataStack)) + return; + } + } + + ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s), + FICL_STRING_GET_POINTER(s)); + /* back to inner interpreter */ +} + +/* + * Surrogate precompiled parse step for ficlParseWord + * (this step is hard coded in FICL_VM_STATE_INTERPRET) + */ +static void +ficlPrimitiveLookup(ficlVm *vm) +{ + ficlString name; + FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack)); + FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack)); + ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name)); +} + +/* + * p a r e n P a r s e S t e p + * (parse-step) ( c-addr u -- flag ) + * runtime for a precompiled parse step - pop a counted string off the + * stack, run the parse step against it, and push the result flag (FICL_TRUE + * if success, FICL_FALSE otherwise). + */ +void +ficlPrimitiveParseStepParen(ficlVm *vm) +{ + ficlString s; + ficlWord *word = vm->runningWord; + ficlParseStep pStep = (ficlParseStep)(word->param->fn); + + FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack)); + FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack)); + + ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s)); +} + +static void +ficlPrimitiveAddParseStep(ficlVm *vm) +{ + ficlWord *pStep; + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p); + if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep)) + ficlSystemAddParseStep(vm->callback.system, pStep); +} + +/* + * l i t e r a l I m + * + * IMMEDIATE code for "literal". This function gets a value from the stack + * and compiles it into the dictionary preceded by the code for "(literal)". + * IMMEDIATE + */ +void +ficlPrimitiveLiteralIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlInteger value; + + value = ficlStackPopInteger(vm->dataStack); + + switch (value) { + case 1: + case 2: + case 3: + case 4: + case 5: + case 6: + case 7: + case 8: + case 9: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 16: + ficlDictionaryAppendUnsigned(dictionary, value); + break; + + case 0: + case -1: + case -2: + case -3: + case -4: + case -5: + case -6: + case -7: + case -8: + case -9: + case -10: + case -11: + case -12: + case -13: + case -14: + case -15: + case -16: + ficlDictionaryAppendUnsigned(dictionary, + ficlInstruction0 - value); + break; + + default: + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionLiteralParen); + ficlDictionaryAppendUnsigned(dictionary, value); + break; + } +} + +static void +ficlPrimitive2LiteralIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen); + ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack)); + ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack)); +} + +/* + * D o / L o o p + * do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY + * Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do), + * allot space to hold the "leave" address, push a branch + * target address for the loop. + * (do) -- runtime for "do" + * pops index and limit from the p stack and moves them + * to the r stack, then skips to the loop body. + * loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY + * +loop + * Compiles code for the test part of a loop: + * FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and + * copy "here" address to the "leave" address allotted by "do" + * i,j,k -- FICL_VM_STATE_COMPILE ONLY + * Runtime: Push loop indices on param stack (i is innermost loop...) + * Note: each loop has three values on the return stack: + * ( R: leave limit index ) + * "leave" is the absolute address of the next ficlCell after the loop + * limit and index are the loop control variables. + * leave -- FICL_VM_STATE_COMPILE ONLY + * Runtime: pop the loop control variables, then pop the + * "leave" address and jump (absolute) there. + */ +static void +ficlPrimitiveDoCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen); + /* + * Allot space for a pointer to the end + * of the loop - "leave" uses this... + */ + markBranch(dictionary, vm, leaveTag); + ficlDictionaryAppendUnsigned(dictionary, 0); + /* + * Mark location of head of loop... + */ + markBranch(dictionary, vm, doTag); +} + +static void +ficlPrimitiveQDoCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen); + /* + * Allot space for a pointer to the end + * of the loop - "leave" uses this... + */ + markBranch(dictionary, vm, leaveTag); + ficlDictionaryAppendUnsigned(dictionary, 0); + /* + * Mark location of head of loop... + */ + markBranch(dictionary, vm, doTag); +} + + +static void +ficlPrimitiveLoopCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen); + resolveBackBranch(dictionary, vm, doTag); + resolveAbsBranch(dictionary, vm, leaveTag); +} + +static void +ficlPrimitivePlusLoopCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen); + resolveBackBranch(dictionary, vm, doTag); + resolveAbsBranch(dictionary, vm, leaveTag); +} + +/* + * v a r i a b l e + */ +static void +ficlPrimitiveVariable(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT); + ficlVmDictionaryAllotCells(vm, dictionary, 1); +} + +static void +ficlPrimitive2Variable(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT); + ficlVmDictionaryAllotCells(vm, dictionary, 2); +} + +/* + * b a s e & f r i e n d s + */ +static void +ficlPrimitiveBase(ficlVm *vm) +{ + ficlCell *pBase, c; + + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + pBase = (ficlCell *)(&vm->base); + c.p = pBase; + ficlStackPush(vm->dataStack, c); +} + +static void +ficlPrimitiveDecimal(ficlVm *vm) +{ + vm->base = 10; +} + + +static void +ficlPrimitiveHex(ficlVm *vm) +{ + vm->base = 16; +} + +/* + * a l l o t & f r i e n d s + */ +static void +ficlPrimitiveAllot(ficlVm *vm) +{ + ficlDictionary *dictionary; + ficlInteger i; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + dictionary = ficlVmGetDictionary(vm); + i = ficlStackPopInteger(vm->dataStack); + + FICL_VM_DICTIONARY_CHECK(vm, dictionary, i); + + ficlVmDictionaryAllot(vm, dictionary, i); +} + +static void +ficlPrimitiveHere(ficlVm *vm) +{ + ficlDictionary *dictionary; + + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + dictionary = ficlVmGetDictionary(vm); + ficlStackPushPointer(vm->dataStack, dictionary->here); +} + +/* + * t i c k + * tick CORE ( "<spaces>name" -- xt ) + * Skip leading space delimiters. Parse name delimited by a space. Find + * name and return xt, the execution token for name. An ambiguous condition + * exists if name is not found. + */ +void +ficlPrimitiveTick(ficlVm *vm) +{ + ficlWord *word = NULL; + ficlString name = ficlVmGetWord(vm); + + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name); + if (!word) + ficlVmThrowError(vm, "%.*s not found", + FICL_STRING_GET_LENGTH(name), + FICL_STRING_GET_POINTER(name)); + ficlStackPushPointer(vm->dataStack, word); +} + +static void +ficlPrimitiveBracketTickCoIm(ficlVm *vm) +{ + ficlPrimitiveTick(vm); + ficlPrimitiveLiteralIm(vm); +} + +/* + * p o s t p o n e + * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to + * insert it into definitions created by the resulting word + * (defers compilation, even of immediate words) + */ +static void +ficlPrimitivePostponeCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *word; + ficlWord *pComma = ficlSystemLookup(vm->callback.system, ","); + ficlCell c; + + FICL_VM_ASSERT(vm, pComma); + + ficlPrimitiveTick(vm); + word = ficlStackGetTop(vm->dataStack).p; + if (ficlWordIsImmediate(word)) { + ficlDictionaryAppendCell(dictionary, + ficlStackPop(vm->dataStack)); + } else { + ficlPrimitiveLiteralIm(vm); + c.p = pComma; + ficlDictionaryAppendCell(dictionary, c); + } +} + +/* + * e x e c u t e + * Pop an execution token (pointer to a word) off the stack and + * run it + */ +static void +ficlPrimitiveExecute(ficlVm *vm) +{ + ficlWord *word; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + word = ficlStackPopPointer(vm->dataStack); + ficlVmExecuteWord(vm, word); +} + +/* + * i m m e d i a t e + * Make the most recently compiled word IMMEDIATE -- it executes even + * in FICL_VM_STATE_COMPILE state (most often used for control compiling words + * such as IF, THEN, etc) + */ +static void +ficlPrimitiveImmediate(ficlVm *vm) +{ + FICL_IGNORE(vm); + ficlDictionarySetImmediate(ficlVmGetDictionary(vm)); +} + +static void +ficlPrimitiveCompileOnly(ficlVm *vm) +{ + FICL_IGNORE(vm); + ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY); +} + +static void +ficlPrimitiveSetObjectFlag(ficlVm *vm) +{ + FICL_IGNORE(vm); + ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT); +} + +static void +ficlPrimitiveIsObject(ficlVm *vm) +{ + ficlInteger flag; + ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack); + + flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT))? + FICL_TRUE : FICL_FALSE; + + ficlStackPushInteger(vm->dataStack, flag); +} + +static void +ficlPrimitiveCountedStringQuoteIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + if (vm->state == FICL_VM_STATE_INTERPRET) { + ficlCountedString *counted = (ficlCountedString *) + dictionary->here; + + ficlVmGetString(vm, counted, '\"'); + ficlStackPushPointer(vm->dataStack, counted); + + /* + * move HERE past string so it doesn't get overwritten. --lch + */ + ficlVmDictionaryAllot(vm, dictionary, + counted->length + sizeof (ficlUnsigned8)); + } else { /* FICL_VM_STATE_COMPILE state */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionCStringLiteralParen); + dictionary->here = + FICL_POINTER_TO_CELL(ficlVmGetString(vm, + (ficlCountedString *)dictionary->here, '\"')); + ficlDictionaryAlign(dictionary); + } +} + +/* + * d o t Q u o t e + * IMMEDIATE word that compiles a string literal for later display + * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the + * string from the + * TIB to the dictionary. Backpatch the count byte and align the dictionary. + */ +static void +ficlPrimitiveDotQuoteCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *pType = ficlSystemLookup(vm->callback.system, "type"); + ficlCell c; + + FICL_VM_ASSERT(vm, pType); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionStringLiteralParen); + dictionary->here = + FICL_POINTER_TO_CELL(ficlVmGetString(vm, + (ficlCountedString *)dictionary->here, '\"')); + ficlDictionaryAlign(dictionary); + c.p = pType; + ficlDictionaryAppendCell(dictionary, c); +} + +static void +ficlPrimitiveDotParen(ficlVm *vm) +{ + char *from = ficlVmGetInBuf(vm); + char *stop = ficlVmGetInBufEnd(vm); + char *to = vm->pad; + char c; + + /* + * Note: the standard does not want leading spaces skipped. + */ + for (c = *from; (from != stop) && (c != ')'); c = *++from) + *to++ = c; + + *to = '\0'; + if ((from != stop) && (c == ')')) + from++; + + ficlVmTextOut(vm, vm->pad); + ficlVmUpdateTib(vm, from); +} + +/* + * s l i t e r a l + * STRING + * Interpretation: Interpretation semantics for this word are undefined. + * Compilation: ( c-addr1 u -- ) + * Append the run-time semantics given below to the current definition. + * Run-time: ( -- c-addr2 u ) + * Return c-addr2 u describing a string consisting of the characters + * specified by c-addr1 u during compilation. A program shall not alter + * the returned string. + */ +static void ficlPrimitiveSLiteralCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary; + char *from; + char *to; + ficlUnsigned length; + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + dictionary = ficlVmGetDictionary(vm); + length = ficlStackPopUnsigned(vm->dataStack); + from = ficlStackPopPointer(vm->dataStack); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionStringLiteralParen); + to = (char *)dictionary->here; + *to++ = (char)length; + + for (; length > 0; --length) { + *to++ = *from++; + } + + *to++ = 0; + dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to)); +} + +/* + * s t a t e + * Return the address of the VM's state member (must be sized the + * same as a ficlCell for this reason) + */ +static void ficlPrimitiveState(ficlVm *vm) +{ + FICL_STACK_CHECK(vm->dataStack, 0, 1); + ficlStackPushPointer(vm->dataStack, &vm->state); +} + +/* + * c r e a t e . . . d o e s > + * Make a new word in the dictionary with the run-time effect of + * a variable (push my address), but with extra space allotted + * for use by does> . + */ +static void +ficlPrimitiveCreate(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + + ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT); + ficlVmDictionaryAllotCells(vm, dictionary, 1); +} + +static void +ficlPrimitiveDoesCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); +#if FICL_WANT_LOCALS + if (vm->callback.system->localsCount > 0) { + ficlDictionary *locals = + ficlSystemGetLocals(vm->callback.system); + ficlDictionaryEmpty(locals, locals->forthWordlist->size); + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionUnlinkParen); + } + + vm->callback.system->localsCount = 0; +#endif + FICL_IGNORE(vm); + + ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen); +} + +/* + * t o b o d y + * to-body CORE ( xt -- a-addr ) + * a-addr is the data-field address corresponding to xt. An ambiguous + * condition exists if xt is not for a word defined via CREATE. + */ +static void +ficlPrimitiveToBody(ficlVm *vm) +{ + ficlWord *word; + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + word = ficlStackPopPointer(vm->dataStack); + ficlStackPushPointer(vm->dataStack, word->param + 1); +} + +/* + * from-body Ficl ( a-addr -- xt ) + * Reverse effect of >body + */ +static void +ficlPrimitiveFromBody(ficlVm *vm) +{ + char *ptr; + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord); + ficlStackPushPointer(vm->dataStack, ptr); +} + +/* + * >name Ficl ( xt -- c-addr u ) + * Push the address and length of a word's name given its address + * xt. + */ +static void +ficlPrimitiveToName(ficlVm *vm) +{ + ficlWord *word; + + FICL_STACK_CHECK(vm->dataStack, 1, 2); + + word = ficlStackPopPointer(vm->dataStack); + ficlStackPushPointer(vm->dataStack, word->name); + ficlStackPushUnsigned(vm->dataStack, word->length); +} + +static void +ficlPrimitiveLastWord(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *wp = dictionary->smudge; + ficlCell c; + + FICL_VM_ASSERT(vm, wp); + + c.p = wp; + ficlVmPush(vm, c); +} + +/* + * l b r a c k e t e t c + */ +static void +ficlPrimitiveLeftBracketCoIm(ficlVm *vm) +{ + vm->state = FICL_VM_STATE_INTERPRET; +} + +static void +ficlPrimitiveRightBracket(ficlVm *vm) +{ + vm->state = FICL_VM_STATE_COMPILE; +} + +/* + * p i c t u r e d n u m e r i c w o r d s + * + * less-number-sign CORE ( -- ) + * Initialize the pictured numeric output conversion process. + * (clear the pad) + */ +static void +ficlPrimitiveLessNumberSign(ficlVm *vm) +{ + ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + counted->length = 0; +} + +/* + * number-sign CORE ( ud1 -- ud2 ) + * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder + * n. (n is the least-significant digit of ud1.) Convert n to external form + * and add the resulting character to the beginning of the pictured numeric + * output string. An ambiguous condition exists if # executes outside of a + * <# #> delimited number conversion. + */ +static void +ficlPrimitiveNumberSign(ficlVm *vm) +{ + ficlCountedString *counted; + ficl2Unsigned u; + ficl2UnsignedQR uqr; + + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + u = ficlStackPop2Unsigned(vm->dataStack); + uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base)); + counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder); + ficlStackPush2Unsigned(vm->dataStack, uqr.quotient); +} + +/* + * number-sign-greater CORE ( xd -- c-addr u ) + * Drop xd. Make the pictured numeric output string available as a character + * string. c-addr and u specify the resulting character string. A program + * may replace characters within the string. + */ +static void +ficlPrimitiveNumberSignGreater(ficlVm *vm) +{ + ficlCountedString *counted; + + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + counted->text[counted->length] = 0; + ficlStringReverse(counted->text); + ficlStackDrop(vm->dataStack, 2); + ficlStackPushPointer(vm->dataStack, counted->text); + ficlStackPushUnsigned(vm->dataStack, counted->length); +} + +/* + * number-sign-s CORE ( ud1 -- ud2 ) + * Convert one digit of ud1 according to the rule for #. Continue conversion + * until the quotient is zero. ud2 is zero. An ambiguous condition exists if + * #S executes outside of a <# #> delimited number conversion. + * TO DO: presently does not use ud1 hi ficlCell - use it! + */ +static void +ficlPrimitiveNumberSignS(ficlVm *vm) +{ + ficlCountedString *counted; + ficl2Unsigned u; + ficl2UnsignedQR uqr; + + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + u = ficlStackPop2Unsigned(vm->dataStack); + + do { + uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base)); + counted->text[counted->length++] = + ficlDigitToCharacter(uqr.remainder); + u = uqr.quotient; + } while (FICL_2UNSIGNED_NOT_ZERO(u)); + + ficlStackPush2Unsigned(vm->dataStack, u); +} + +/* + * HOLD CORE ( char -- ) + * Add char to the beginning of the pictured numeric output string. + * An ambiguous condition exists if HOLD executes outside of a <# #> + * delimited number conversion. + */ +static void +ficlPrimitiveHold(ficlVm *vm) +{ + ficlCountedString *counted; + int i; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + i = ficlStackPopInteger(vm->dataStack); + counted->text[counted->length++] = (char)i; +} + +/* + * SIGN CORE ( n -- ) + * If n is negative, add a minus sign to the beginning of the pictured + * numeric output string. An ambiguous condition exists if SIGN + * executes outside of a <# #> delimited number conversion. + */ +static void +ficlPrimitiveSign(ficlVm *vm) +{ + ficlCountedString *counted; + int i; + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); + i = ficlStackPopInteger(vm->dataStack); + if (i < 0) + counted->text[counted->length++] = '-'; +} + +/* + * t o N u m b e r + * to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) + * ud2 is the unsigned result of converting the characters within the + * string specified by c-addr1 u1 into digits, using the number in BASE, + * and adding each into ud1 after multiplying ud1 by the number in BASE. + * Conversion continues left-to-right until a character that is not + * convertible, including any + or -, is encountered or the string is + * entirely converted. c-addr2 is the location of the first unconverted + * character or the first character past the end of the string if the string + * was entirely converted. u2 is the number of unconverted characters in the + * string. An ambiguous condition exists if ud2 overflows during the + * conversion. + */ +static void +ficlPrimitiveToNumber(ficlVm *vm) +{ + ficlUnsigned length; + char *trace; + ficl2Unsigned accumulator; + ficlUnsigned base = vm->base; + ficlUnsigned c; + ficlUnsigned digit; + + FICL_STACK_CHECK(vm->dataStack, 4, 4); + + length = ficlStackPopUnsigned(vm->dataStack); + trace = (char *)ficlStackPopPointer(vm->dataStack); + accumulator = ficlStackPop2Unsigned(vm->dataStack); + + for (c = *trace; length > 0; c = *++trace, length--) { + if (c < '0') + break; + + digit = c - '0'; + + if (digit > 9) + digit = tolower(c) - 'a' + 10; + /* + * Note: following test also catches chars between 9 and a + * because 'digit' is unsigned! + */ + if (digit >= base) + break; + + accumulator = ficl2UnsignedMultiplyAccumulate(accumulator, + base, digit); + } + + ficlStackPush2Unsigned(vm->dataStack, accumulator); + ficlStackPushPointer(vm->dataStack, trace); + ficlStackPushUnsigned(vm->dataStack, length); +} + +/* + * q u i t & a b o r t + * quit CORE ( -- ) ( R: i*x -- ) + * Empty the return stack, store zero in SOURCE-ID if it is present, make + * the user input device the input source, and enter interpretation state. + * Do not display a message. Repeat the following: + * + * Accept a line from the input source into the input buffer, set >IN to + * zero, and FICL_VM_STATE_INTERPRET. + * Display the implementation-defined system prompt if in + * interpretation state, all processing has been completed, and no + * ambiguous condition exists. + */ +static void +ficlPrimitiveQuit(ficlVm *vm) +{ + ficlVmThrow(vm, FICL_VM_STATUS_QUIT); +} + +static void +ficlPrimitiveAbort(ficlVm *vm) +{ + ficlVmThrow(vm, FICL_VM_STATUS_ABORT); +} + +/* + * a c c e p t + * accept CORE ( c-addr +n1 -- +n2 ) + * Receive a string of at most +n1 characters. An ambiguous condition + * exists if +n1 is zero or greater than 32,767. Display graphic characters + * as they are received. A program that depends on the presence or absence + * of non-graphic characters in the string has an environmental dependency. + * The editing functions, if any, that the system performs in order to + * construct the string are implementation-defined. + * + * (Although the standard text doesn't say so, I assume that the intent + * of 'accept' is to store the string at the address specified on + * the stack.) + * + * NOTE: getchar() is used there as its present both in loader and + * userland; however, the more correct solution would be to set + * terminal to raw mode for userland. + */ +static void +ficlPrimitiveAccept(ficlVm *vm) +{ + ficlUnsigned size; + char *address; + int c; + ficlUnsigned length = 0; + + FICL_STACK_CHECK(vm->dataStack, 2, 1); + + size = ficlStackPopInteger(vm->dataStack); + address = ficlStackPopPointer(vm->dataStack); + + while (size != length) { + c = getchar(); + if (c == '\n' || c == '\r') + break; + address[length++] = c; + } + ficlStackPushInteger(vm->dataStack, length); +} + +/* + * a l i g n + * 6.1.0705 ALIGN CORE ( -- ) + * If the data-space pointer is not aligned, reserve enough space to + * align it. + */ +static void +ficlPrimitiveAlign(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + FICL_IGNORE(vm); + ficlDictionaryAlign(dictionary); +} + +/* + * a l i g n e d + */ +static void +ficlPrimitiveAligned(ficlVm *vm) +{ + void *addr; + + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + addr = ficlStackPopPointer(vm->dataStack); + ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr)); +} + +/* + * b e g i n & f r i e n d s + * Indefinite loop control structures + * A.6.1.0760 BEGIN + * Typical use: + * : X ... BEGIN ... test UNTIL ; + * or + * : X ... BEGIN ... test WHILE ... REPEAT ; + */ +static void +ficlPrimitiveBeginCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + markBranch(dictionary, vm, destTag); +} + +static void +ficlPrimitiveUntilCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranch0ParenWithCheck); + resolveBackBranch(dictionary, vm, destTag); +} + +static void +ficlPrimitiveWhileCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + FICL_STACK_CHECK(vm->dataStack, 2, 5); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranch0ParenWithCheck); + markBranch(dictionary, vm, origTag); + + /* equivalent to 2swap */ + ficlStackRoll(vm->dataStack, 3); + ficlStackRoll(vm->dataStack, 3); + + ficlDictionaryAppendUnsigned(dictionary, 1); +} + +static void +ficlPrimitiveRepeatCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranchParenWithCheck); + /* expect "begin" branch marker */ + resolveBackBranch(dictionary, vm, destTag); + /* expect "while" branch marker */ + resolveForwardBranch(dictionary, vm, origTag); +} + +static void +ficlPrimitiveAgainCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionBranchParenWithCheck); + /* expect "begin" branch marker */ + resolveBackBranch(dictionary, vm, destTag); +} + +/* + * c h a r & f r i e n d s + * 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) + * Skip leading space delimiters. Parse name delimited by a space. + * Put the value of its first character onto the stack. + * + * bracket-char CORE + * Interpretation: Interpretation semantics for this word are undefined. + * Compilation: ( "<spaces>name" -- ) + * Skip leading space delimiters. Parse name delimited by a space. + * Append the run-time semantics given below to the current definition. + * Run-time: ( -- char ) + * Place char, the value of the first character of name, on the stack. + */ +static void +ficlPrimitiveChar(ficlVm *vm) +{ + ficlString s; + + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + s = ficlVmGetWord(vm); + ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0])); +} + +static void +ficlPrimitiveCharCoIm(ficlVm *vm) +{ + ficlPrimitiveChar(vm); + ficlPrimitiveLiteralIm(vm); +} + +/* + * c h a r P l u s + * char-plus CORE ( c-addr1 -- c-addr2 ) + * Add the size in address units of a character to c-addr1, giving c-addr2. + */ +static void +ficlPrimitiveCharPlus(ficlVm *vm) +{ + char *p; + + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + p = ficlStackPopPointer(vm->dataStack); + ficlStackPushPointer(vm->dataStack, p + 1); +} + +/* + * c h a r s + * chars CORE ( n1 -- n2 ) + * n2 is the size in address units of n1 characters. + * For most processors, this function can be a no-op. To guarantee + * portability, we'll multiply by sizeof (char). + */ +#if defined(_M_IX86) +#pragma warning(disable: 4127) +#endif +static void +ficlPrimitiveChars(ficlVm *vm) +{ + if (sizeof (char) > 1) { + ficlInteger i; + + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + i = ficlStackPopInteger(vm->dataStack); + ficlStackPushInteger(vm->dataStack, i * sizeof (char)); + } + /* otherwise no-op! */ +} +#if defined(_M_IX86) +#pragma warning(default: 4127) +#endif + +/* + * c o u n t + * COUNT CORE ( c-addr1 -- c-addr2 u ) + * Return the character string specification for the counted string stored + * at c-addr1. c-addr2 is the address of the first character after c-addr1. + * u is the contents of the character at c-addr1, which is the length in + * characters of the string at c-addr2. + */ +static void +ficlPrimitiveCount(ficlVm *vm) +{ + ficlCountedString *counted; + + FICL_STACK_CHECK(vm->dataStack, 1, 2); + + counted = ficlStackPopPointer(vm->dataStack); + ficlStackPushPointer(vm->dataStack, counted->text); + ficlStackPushUnsigned(vm->dataStack, counted->length); +} + +/* + * e n v i r o n m e n t ? + * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE ) + * c-addr is the address of a character string and u is the string's + * character count. u may have a value in the range from zero to an + * implementation-defined maximum which shall not be less than 31. The + * character string should contain a keyword from 3.2.6 Environmental + * queries or the optional word sets to be checked for correspondence + * with an attribute of the present environment. If the system treats the + * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag + * is FICL_TRUE and the i*x returned is of the type specified in the table for + * the attribute queried. + */ +static void +ficlPrimitiveEnvironmentQ(ficlVm *vm) +{ + ficlDictionary *environment; + ficlWord *word; + ficlString name; + + FICL_STACK_CHECK(vm->dataStack, 2, 1); + + environment = vm->callback.system->environment; + name.length = ficlStackPopUnsigned(vm->dataStack); + name.text = ficlStackPopPointer(vm->dataStack); + + word = ficlDictionaryLookup(environment, name); + + if (word != NULL) { + ficlVmExecuteWord(vm, word); + ficlStackPushInteger(vm->dataStack, FICL_TRUE); + } else { + ficlStackPushInteger(vm->dataStack, FICL_FALSE); + } +} + +/* + * e v a l u a t e + * EVALUATE CORE ( i*x c-addr u -- j*x ) + * Save the current input source specification. Store minus-one (-1) in + * SOURCE-ID if it is present. Make the string described by c-addr and u + * both the input source and input buffer, set >IN to zero, and + * FICL_VM_STATE_INTERPRET. + * When the parse area is empty, restore the prior input source + * specification. Other stack effects are due to the words EVALUATEd. + */ +static void +ficlPrimitiveEvaluate(ficlVm *vm) +{ + ficlCell id; + int result; + ficlString string; + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack)); + FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack)); + + id = vm->sourceId; + vm->sourceId.i = -1; + result = ficlVmExecuteString(vm, string); + vm->sourceId = id; + if (result != FICL_VM_STATUS_OUT_OF_TEXT) + ficlVmThrow(vm, result); +} + +/* + * s t r i n g q u o t e + * Interpreting: get string delimited by a quote from the input stream, + * copy to a scratch area, and put its count and address on the stack. + * Compiling: FICL_VM_STATE_COMPILE code to push the address and count + * of a string literal, FICL_VM_STATE_COMPILE the string from the input + * stream, and align the dictionary pointer. + */ +static void +ficlPrimitiveStringQuoteIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + + if (vm->state == FICL_VM_STATE_INTERPRET) { + ficlCountedString *counted; + counted = (ficlCountedString *)dictionary->here; + ficlVmGetString(vm, counted, '\"'); + ficlStackPushPointer(vm->dataStack, counted->text); + ficlStackPushUnsigned(vm->dataStack, counted->length); + } else { /* FICL_VM_STATE_COMPILE state */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionStringLiteralParen); + dictionary->here = FICL_POINTER_TO_CELL( + ficlVmGetString(vm, (ficlCountedString *)dictionary->here, + '\"')); + ficlDictionaryAlign(dictionary); + } +} + +/* + * t y p e + * Pop count and char address from stack and print the designated string. + */ +static void +ficlPrimitiveType(ficlVm *vm) +{ + ficlUnsigned length; + char *s; + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + length = ficlStackPopUnsigned(vm->dataStack); + s = ficlStackPopPointer(vm->dataStack); + + if ((s == NULL) || (length == 0)) + return; + + /* + * Since we don't have an output primitive for a counted string + * (oops), make sure the string is null terminated. If not, copy + * and terminate it. + */ + if (s[length] != 0) { + char *here = (char *)ficlVmGetDictionary(vm)->here; + if (s != here) + strncpy(here, s, length); + + here[length] = '\0'; + s = here; + } + + ficlVmTextOut(vm, s); +} + +/* + * w o r d + * word CORE ( char "<chars>ccc<char>" -- c-addr ) + * Skip leading delimiters. Parse characters ccc delimited by char. An + * ambiguous condition exists if the length of the parsed string is greater + * than the implementation-defined length of a counted string. + * + * c-addr is the address of a transient region containing the parsed word + * as a counted string. If the parse area was empty or contained no + * characters other than the delimiter, the resulting string has a zero + * length. A space, not included in the length, follows the string. A + * program may replace characters within the string. + * NOTE! Ficl also NULL-terminates the dest string. + */ +static void +ficlPrimitiveWord(ficlVm *vm) +{ + ficlCountedString *counted; + char delim; + ficlString name; + + FICL_STACK_CHECK(vm->dataStack, 1, 1); + + counted = (ficlCountedString *)vm->pad; + delim = (char)ficlStackPopInteger(vm->dataStack); + name = ficlVmParseStringEx(vm, delim, 1); + + if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1) + FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1); + + counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name); + strncpy(counted->text, FICL_STRING_GET_POINTER(name), + FICL_STRING_GET_LENGTH(name)); + + /* + * store an extra space at the end of the primitive... + * why? dunno yet. Guy Carver did it. + */ + counted->text[counted->length] = ' '; + counted->text[counted->length + 1] = 0; + + ficlStackPushPointer(vm->dataStack, counted); +} + +/* + * p a r s e - w o r d + * Ficl PARSE-WORD ( <spaces>name -- c-addr u ) + * Skip leading spaces and parse name delimited by a space. c-addr is the + * address within the input buffer and u is the length of the selected + * string. If the parse area is empty, the resulting string has a zero length. + */ +static void ficlPrimitiveParseNoCopy(ficlVm *vm) +{ + ficlString s; + + FICL_STACK_CHECK(vm->dataStack, 0, 2); + + s = ficlVmGetWord0(vm); + ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s)); + ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s)); +} + +/* + * p a r s e + * CORE EXT ( char "ccc<char>" -- c-addr u ) + * Parse ccc delimited by the delimiter char. + * c-addr is the address (within the input buffer) and u is the length of + * the parsed string. If the parse area was empty, the resulting string has + * a zero length. + * NOTE! PARSE differs from WORD: it does not skip leading delimiters. + */ +static void +ficlPrimitiveParse(ficlVm *vm) +{ + ficlString s; + char delim; + + FICL_STACK_CHECK(vm->dataStack, 1, 2); + + delim = (char)ficlStackPopInteger(vm->dataStack); + + s = ficlVmParseStringEx(vm, delim, 0); + ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s)); + ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s)); +} + +/* + * f i n d + * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) + * Find the definition named in the counted string at c-addr. If the + * definition is not found, return c-addr and zero. If the definition is + * found, return its execution token xt. If the definition is immediate, + * also return one (1), otherwise also return minus-one (-1). For a given + * string, the values returned by FIND while compiling may differ from + * those returned while not compiling. + */ +static void +do_find(ficlVm *vm, ficlString name, void *returnForFailure) +{ + ficlWord *word; + + word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name); + if (word) { + ficlStackPushPointer(vm->dataStack, word); + ficlStackPushInteger(vm->dataStack, + (ficlWordIsImmediate(word) ? 1 : -1)); + } else { + ficlStackPushPointer(vm->dataStack, returnForFailure); + ficlStackPushUnsigned(vm->dataStack, 0); + } +} + +/* + * f i n d + * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) + * Find the definition named in the counted string at c-addr. If the + * definition is not found, return c-addr and zero. If the definition is + * found, return its execution token xt. If the definition is immediate, + * also return one (1), otherwise also return minus-one (-1). For a given + * string, the values returned by FIND while compiling may differ from + * those returned while not compiling. + */ +static void +ficlPrimitiveCFind(ficlVm *vm) +{ + ficlCountedString *counted; + ficlString name; + + FICL_STACK_CHECK(vm->dataStack, 1, 2); + + counted = ficlStackPopPointer(vm->dataStack); + FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted); + do_find(vm, name, counted); +} + +/* + * s f i n d + * Ficl ( c-addr u -- 0 0 | xt 1 | xt -1 ) + * Like FIND, but takes "c-addr u" for the string. + */ +static void +ficlPrimitiveSFind(ficlVm *vm) +{ + ficlString name; + + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + name.length = ficlStackPopInteger(vm->dataStack); + name.text = ficlStackPopPointer(vm->dataStack); + + do_find(vm, name, NULL); +} + +/* + * r e c u r s e + */ +static void +ficlPrimitiveRecurseCoIm(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlCell c; + + FICL_IGNORE(vm); + c.p = dictionary->smudge; + ficlDictionaryAppendCell(dictionary, c); +} + +/* + * s o u r c e + * CORE ( -- c-addr u ) + * c-addr is the address of, and u is the number of characters in, the + * input buffer. + */ +static void +ficlPrimitiveSource(ficlVm *vm) +{ + FICL_STACK_CHECK(vm->dataStack, 0, 2); + + ficlStackPushPointer(vm->dataStack, vm->tib.text); + ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm)); +} + +/* + * v e r s i o n + * non-standard... + */ +static void +ficlPrimitiveVersion(ficlVm *vm) +{ + ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n"); +} + +/* + * t o I n + * to-in CORE + */ +static void +ficlPrimitiveToIn(ficlVm *vm) +{ + FICL_STACK_CHECK(vm->dataStack, 0, 1); + + ficlStackPushPointer(vm->dataStack, &vm->tib.index); +} + +/* + * c o l o n N o N a m e + * CORE EXT ( C: -- colon-sys ) ( S: -- xt ) + * Create an unnamed colon definition and push its address. + * Change state to FICL_VM_STATE_COMPILE. + */ +static void +ficlPrimitiveColonNoName(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *word; + ficlString name; + + FICL_STRING_SET_LENGTH(name, 0); + FICL_STRING_SET_POINTER(name, NULL); + + vm->state = FICL_VM_STATE_COMPILE; + word = ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionColonParen, + FICL_WORD_DEFAULT | FICL_WORD_SMUDGED); + + ficlStackPushPointer(vm->dataStack, word); + markControlTag(vm, colonTag); +} + +/* + * u s e r V a r i a b l e + * user ( u -- ) "<spaces>name" + * Get a name from the input stream and create a user variable + * with the name and the index supplied. The run-time effect + * of a user variable is to push the address of the indexed ficlCell + * in the running vm's user array. + * + * User variables are vm local cells. Each vm has an array of + * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. + * Ficl's user facility is implemented with two primitives, + * "user" and "(user)", a variable ("nUser") (in softcore.c) that + * holds the index of the next free user ficlCell, and a redefinition + * (also in softcore) of "user" that defines a user word and increments + * nUser. + */ +#if FICL_WANT_USER +static void +ficlPrimitiveUser(ficlVm *vm) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlString name = ficlVmGetWord(vm); + ficlCell c; + + c = ficlStackPop(vm->dataStack); + if (c.i >= FICL_USER_CELLS) { + ficlVmThrowError(vm, "Error - out of user space"); + } + + ficlDictionaryAppendWord(dictionary, name, + (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT); + ficlDictionaryAppendCell(dictionary, c); +} +#endif + +#if FICL_WANT_LOCALS +/* + * Each local is recorded in a private locals dictionary as a + * word that does doLocalIm at runtime. DoLocalIm compiles code + * into the client definition to fetch the value of the + * corresponding local variable from the return stack. + * The private dictionary gets initialized at the end of each block + * that uses locals (in ; and does> for example). + */ +void +ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat) +{ + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlInteger nLocal = vm->runningWord->param[0].i; + +#if !FICL_WANT_FLOAT + FICL_VM_ASSERT(vm, !isFloat); + /* get rid of unused parameter warning */ + isFloat = 0; +#endif /* FICL_WANT_FLOAT */ + + if (vm->state == FICL_VM_STATE_INTERPRET) { + ficlStack *stack; +#if FICL_WANT_FLOAT + if (isFloat) + stack = vm->floatStack; + else +#endif /* FICL_WANT_FLOAT */ + stack = vm->dataStack; + + ficlStackPush(stack, vm->returnStack->frame[nLocal]); + if (isDouble) + ficlStackPush(stack, vm->returnStack->frame[nLocal+1]); + } else { + ficlInstruction instruction; + ficlInteger appendLocalOffset; +#if FICL_WANT_FLOAT + if (isFloat) { + instruction = + (isDouble) ? ficlInstructionGetF2LocalParen : + ficlInstructionGetFLocalParen; + appendLocalOffset = FICL_TRUE; + } else +#endif /* FICL_WANT_FLOAT */ + if (nLocal == 0) { + instruction = (isDouble) ? ficlInstructionGet2Local0 : + ficlInstructionGetLocal0; + appendLocalOffset = FICL_FALSE; + } else if ((nLocal == 1) && !isDouble) { + instruction = ficlInstructionGetLocal1; + appendLocalOffset = FICL_FALSE; + } else { + instruction = + (isDouble) ? ficlInstructionGet2LocalParen : + ficlInstructionGetLocalParen; + appendLocalOffset = FICL_TRUE; + } + + ficlDictionaryAppendUnsigned(dictionary, instruction); + if (appendLocalOffset) + ficlDictionaryAppendUnsigned(dictionary, nLocal); + } +} + +static void +ficlPrimitiveDoLocalIm(ficlVm *vm) +{ + ficlLocalParenIm(vm, 0, 0); +} + +static void +ficlPrimitiveDo2LocalIm(ficlVm *vm) +{ + ficlLocalParenIm(vm, 1, 0); +} + +#if FICL_WANT_FLOAT +static void +ficlPrimitiveDoFLocalIm(ficlVm *vm) +{ + ficlLocalParenIm(vm, 0, 1); +} + +static void +ficlPrimitiveDoF2LocalIm(ficlVm *vm) +{ + ficlLocalParenIm(vm, 1, 1); +} +#endif /* FICL_WANT_FLOAT */ + +/* + * l o c a l P a r e n + * paren-local-paren LOCAL + * Interpretation: Interpretation semantics for this word are undefined. + * Execution: ( c-addr u -- ) + * When executed during compilation, (LOCAL) passes a message to the + * system that has one of two meanings. If u is non-zero, + * the message identifies a new local whose definition name is given by + * the string of characters identified by c-addr u. If u is zero, + * the message is last local and c-addr has no significance. + * + * The result of executing (LOCAL) during compilation of a definition is + * to create a set of named local identifiers, each of which is + * a definition name, that only have execution semantics within the scope + * of that definition's source. + * + * local Execution: ( -- x ) + * + * Push the local's value, x, onto the stack. The local's value is + * initialized as described in 13.3.3 Processing locals and may be + * changed by preceding the local's name with TO. An ambiguous condition + * exists when local is executed while in interpretation state. + */ +void +ficlLocalParen(ficlVm *vm, int isDouble, int isFloat) +{ + ficlDictionary *dictionary; + ficlString name; + + FICL_STACK_CHECK(vm->dataStack, 2, 0); + + dictionary = ficlVmGetDictionary(vm); + FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack)); + FICL_STRING_SET_POINTER(name, + (char *)ficlStackPopPointer(vm->dataStack)); + + if (FICL_STRING_GET_LENGTH(name) > 0) { + /* + * add a local to the **locals** dictionary and + * update localsCount + */ + ficlPrimitive code; + ficlInstruction instruction; + ficlDictionary *locals; + + locals = ficlSystemGetLocals(vm->callback.system); + if (vm->callback.system->localsCount >= FICL_MAX_LOCALS) { + ficlVmThrowError(vm, "Error: out of local space"); + } + +#if !FICL_WANT_FLOAT + FICL_VM_ASSERT(vm, !isFloat); + /* get rid of unused parameter warning */ + isFloat = 0; +#else /* FICL_WANT_FLOAT */ + if (isFloat) { + if (isDouble) { + code = ficlPrimitiveDoF2LocalIm; + instruction = ficlInstructionToF2LocalParen; + } else { + code = ficlPrimitiveDoFLocalIm; + instruction = ficlInstructionToFLocalParen; + } + } else +#endif /* FICL_WANT_FLOAT */ + if (isDouble) { + code = ficlPrimitiveDo2LocalIm; + instruction = ficlInstructionTo2LocalParen; + } else { + code = ficlPrimitiveDoLocalIm; + instruction = ficlInstructionToLocalParen; + } + + ficlDictionaryAppendWord(locals, name, code, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionaryAppendUnsigned(locals, + vm->callback.system->localsCount); + + if (vm->callback.system->localsCount == 0) { + /* + * FICL_VM_STATE_COMPILE code to create a local + * stack frame + */ + ficlDictionaryAppendUnsigned(dictionary, + ficlInstructionLinkParen); + + /* save location in dictionary for #locals */ + vm->callback.system->localsFixup = dictionary->here; + ficlDictionaryAppendUnsigned(dictionary, + vm->callback.system->localsCount); + } + + ficlDictionaryAppendUnsigned(dictionary, instruction); + ficlDictionaryAppendUnsigned(dictionary, + vm->callback.system->localsCount); + + vm->callback.system->localsCount += (isDouble) ? 2 : 1; + } else if (vm->callback.system->localsCount > 0) { + /* write localsCount to (link) param area in dictionary */ + *(ficlInteger *)(vm->callback.system->localsFixup) = + vm->callback.system->localsCount; + } +} + +static void +ficlPrimitiveLocalParen(ficlVm *vm) +{ + ficlLocalParen(vm, 0, 0); +} + +static void +ficlPrimitive2LocalParen(ficlVm *vm) +{ + ficlLocalParen(vm, 1, 0); +} +#endif /* FICL_WANT_LOCALS */ + +/* + * t o V a l u e + * CORE EXT + * Interpretation: ( x "<spaces>name" -- ) + * Skip leading spaces and parse name delimited by a space. Store x in + * name. An ambiguous condition exists if name was not defined by VALUE. + * NOTE: In Ficl, VALUE is an alias of CONSTANT + */ +static void +ficlPrimitiveToValue(ficlVm *vm) +{ + ficlString name = ficlVmGetWord(vm); + ficlDictionary *dictionary = ficlVmGetDictionary(vm); + ficlWord *word; + ficlInstruction instruction = 0; + ficlStack *stack; + ficlInteger isDouble; +#if FICL_WANT_LOCALS + ficlInteger nLocal; + ficlInteger appendLocalOffset; + ficlInteger isFloat; +#endif /* FICL_WANT_LOCALS */ + +#if FICL_WANT_LOCALS + if ((vm->callback.system->localsCount > 0) && + (vm->state == FICL_VM_STATE_COMPILE)) { + ficlDictionary *locals; + + locals = ficlSystemGetLocals(vm->callback.system); + word = ficlDictionaryLookup(locals, name); + if (!word) + goto TO_GLOBAL; + + if (word->code == ficlPrimitiveDoLocalIm) { + instruction = ficlInstructionToLocalParen; + isDouble = isFloat = FICL_FALSE; + } else if (word->code == ficlPrimitiveDo2LocalIm) { + instruction = ficlInstructionTo2LocalParen; + isDouble = FICL_TRUE; + isFloat = FICL_FALSE; + } +#if FICL_WANT_FLOAT + else if (word->code == ficlPrimitiveDoFLocalIm) { + instruction = ficlInstructionToFLocalParen; + isDouble = FICL_FALSE; + isFloat = FICL_TRUE; + } else if (word->code == ficlPrimitiveDoF2LocalIm) { + instruction = ficlInstructionToF2LocalParen; + isDouble = isFloat = FICL_TRUE; + } +#endif /* FICL_WANT_FLOAT */ + else { + ficlVmThrowError(vm, + "to %.*s : local is of unknown type", + FICL_STRING_GET_LENGTH(name), + FICL_STRING_GET_POINTER(name)); + return; + } + + nLocal = word->param[0].i; + appendLocalOffset = FICL_TRUE; + +#if FICL_WANT_FLOAT + if (!isFloat) { +#endif /* FICL_WANT_FLOAT */ + if (nLocal == 0) { + instruction = + (isDouble) ? ficlInstructionTo2Local0 : + ficlInstructionToLocal0; + appendLocalOffset = FICL_FALSE; + } else if ((nLocal == 1) && !isDouble) { + instruction = ficlInstructionToLocal1; + appendLocalOffset = FICL_FALSE; + } +#if FICL_WANT_FLOAT + } +#endif /* FICL_WANT_FLOAT */ + + ficlDictionaryAppendUnsigned(dictionary, instruction); + if (appendLocalOffset) + ficlDictionaryAppendUnsigned(dictionary, nLocal); + return; + } +#endif + +#if FICL_WANT_LOCALS +TO_GLOBAL: +#endif /* FICL_WANT_LOCALS */ + word = ficlDictionaryLookup(dictionary, name); + if (!word) + ficlVmThrowError(vm, "%.*s not found", + FICL_STRING_GET_LENGTH(name), + FICL_STRING_GET_POINTER(name)); + + switch ((ficlInstruction)word->code) { + case ficlInstructionConstantParen: + instruction = ficlInstructionStore; + stack = vm->dataStack; + isDouble = FICL_FALSE; + break; + case ficlInstruction2ConstantParen: + instruction = ficlInstruction2Store; + stack = vm->dataStack; + isDouble = FICL_TRUE; + break; +#if FICL_WANT_FLOAT + case ficlInstructionFConstantParen: + instruction = ficlInstructionFStore; + stack = vm->floatStack; + isDouble = FICL_FALSE; + break; + case ficlInstructionF2ConstantParen: + instruction = ficlInstructionF2Store; + stack = vm->floatStack; + isDouble = FICL_TRUE; + break; +#endif /* FICL_WANT_FLOAT */ + default: + ficlVmThrowError(vm, + "to %.*s : value/constant is of unknown type", + FICL_STRING_GET_LENGTH(name), + FICL_STRING_GET_POINTER(name)); + return; + } + + if (vm->state == FICL_VM_STATE_INTERPRET) { + word->param[0] = ficlStackPop(stack); + if (isDouble) + word->param[1] = ficlStackPop(stack); + } else { + /* FICL_VM_STATE_COMPILE code to store to word's param */ + ficlStackPushPointer(vm->dataStack, &word->param[0]); + ficlPrimitiveLiteralIm(vm); + ficlDictionaryAppendUnsigned(dictionary, instruction); + } +} + +/* + * f m S l a s h M o d + * f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) + * Divide d1 by n1, giving the floored quotient n3 and the remainder n2. + * Input and output stack arguments are signed. An ambiguous condition + * exists if n1 is zero or if the quotient lies outside the range of a + * single-ficlCell signed integer. + */ +static void +ficlPrimitiveFMSlashMod(ficlVm *vm) +{ + ficl2Integer d1; + ficlInteger n1; + ficl2IntegerQR qr; + + FICL_STACK_CHECK(vm->dataStack, 3, 2); + + n1 = ficlStackPopInteger(vm->dataStack); + d1 = ficlStackPop2Integer(vm->dataStack); + qr = ficl2IntegerDivideFloored(d1, n1); + ficlStackPushInteger(vm->dataStack, qr.remainder); + ficlStackPushInteger(vm->dataStack, + FICL_2UNSIGNED_GET_LOW(qr.quotient)); +} + +/* + * s m S l a s h R e m + * s-m-slash-remainder CORE ( d1 n1 -- n2 n3 ) + * Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. + * Input and output stack arguments are signed. An ambiguous condition + * exists if n1 is zero or if the quotient lies outside the range of a + * single-ficlCell signed integer. + */ +static void +ficlPrimitiveSMSlashRem(ficlVm *vm) +{ + ficl2Integer d1; + ficlInteger n1; + ficl2IntegerQR qr; + + FICL_STACK_CHECK(vm->dataStack, 3, 2); + + n1 = ficlStackPopInteger(vm->dataStack); + d1 = ficlStackPop2Integer(vm->dataStack); + qr = ficl2IntegerDivideSymmetric(d1, n1); + ficlStackPushInteger(vm->dataStack, qr.remainder); + ficlStackPushInteger(vm->dataStack, + FICL_2UNSIGNED_GET_LOW(qr.quotient)); +} + +static void +ficlPrimitiveMod(ficlVm *vm) +{ + ficl2Integer d1; + ficlInteger n1; + ficlInteger i; + ficl2IntegerQR qr; + FICL_STACK_CHECK(vm->dataStack, 2, 1); + + n1 = ficlStackPopInteger(vm->dataStack); + i = ficlStackPopInteger(vm->dataStack); + FICL_INTEGER_TO_2INTEGER(i, d1); + qr = ficl2IntegerDivideSymmetric(d1, n1); + ficlStackPushInteger(vm->dataStack, qr.remainder); +} + +/* + * u m S l a s h M o d + * u-m-slash-mod CORE ( ud u1 -- u2 u3 ) + * Divide ud by u1, giving the quotient u3 and the remainder u2. + * All values and arithmetic are unsigned. An ambiguous condition + * exists if u1 is zero or if the quotient lies outside the range of a + * single-ficlCell unsigned integer. + */ +static void +ficlPrimitiveUMSlashMod(ficlVm *vm) +{ + ficl2Unsigned ud; + ficlUnsigned u1; + ficl2UnsignedQR uqr; + + u1 = ficlStackPopUnsigned(vm->dataStack); + ud = ficlStackPop2Unsigned(vm->dataStack); + uqr = ficl2UnsignedDivide(ud, u1); + ficlStackPushUnsigned(vm->dataStack, uqr.remainder); + ficlStackPushUnsigned(vm->dataStack, + FICL_2UNSIGNED_GET_LOW(uqr.quotient)); +} + +/* + * m S t a r + * m-star CORE ( n1 n2 -- d ) + * d is the signed product of n1 times n2. + */ +static void +ficlPrimitiveMStar(ficlVm *vm) +{ + ficlInteger n2; + ficlInteger n1; + ficl2Integer d; + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + n2 = ficlStackPopInteger(vm->dataStack); + n1 = ficlStackPopInteger(vm->dataStack); + + d = ficl2IntegerMultiply(n1, n2); + ficlStackPush2Integer(vm->dataStack, d); +} + +static void +ficlPrimitiveUMStar(ficlVm *vm) +{ + ficlUnsigned u2; + ficlUnsigned u1; + ficl2Unsigned ud; + FICL_STACK_CHECK(vm->dataStack, 2, 2); + + u2 = ficlStackPopUnsigned(vm->dataStack); + u1 = ficlStackPopUnsigned(vm->dataStack); + + ud = ficl2UnsignedMultiply(u1, u2); + ficlStackPush2Unsigned(vm->dataStack, ud); +} + +/* + * 2 r o t + * DOUBLE ( d1 d2 d3 -- d2 d3 d1 ) + */ +static void +ficlPrimitive2Rot(ficlVm *vm) +{ + ficl2Integer d1, d2, d3; + FICL_STACK_CHECK(vm->dataStack, 6, 6); + + d3 = ficlStackPop2Integer(vm->dataStack); + d2 = ficlStackPop2Integer(vm->dataStack); + d1 = ficlStackPop2Integer(vm->dataStack); + ficlStackPush2Integer(vm->dataStack, d2); + ficlStackPush2Integer(vm->dataStack, d3); + ficlStackPush2Integer(vm->dataStack, d1); +} + +/* + * p a d + * CORE EXT ( -- c-addr ) + * c-addr is the address of a transient region that can be used to hold + * data for intermediate processing. + */ +static void +ficlPrimitivePad(ficlVm *vm) +{ + ficlStackPushPointer(vm->dataStack, vm->pad); +} + +/* + * s o u r c e - i d + * CORE EXT, FILE ( -- 0 | -1 | fileid ) + * Identifies the input source as follows: + * + * SOURCE-ID Input source + * --------- ------------ + * fileid Text file fileid + * -1 String (via EVALUATE) + * 0 User input device + */ +static void +ficlPrimitiveSourceID(ficlVm *vm) +{ + ficlStackPushInteger(vm->dataStack, vm->sourceId.i); +} + +/* + * r e f i l l + * CORE EXT ( -- flag ) + * Attempt to fill the input buffer from the input source, returning + * a FICL_TRUE flag if successful. + * When the input source is the user input device, attempt to receive input + * into the terminal input buffer. If successful, make the result the input + * buffer, set >IN to zero, and return FICL_TRUE. Receipt of a line containing + * no characters is considered successful. If there is no input available from + * the current input source, return FICL_FALSE. + * When the input source is a string from EVALUATE, return FICL_FALSE and + * perform no other action. + */ +static void +ficlPrimitiveRefill(ficlVm *vm) +{ + ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE; + if (ret && (vm->restart == 0)) + ficlVmThrow(vm, FICL_VM_STATUS_RESTART); + + ficlStackPushInteger(vm->dataStack, ret); +} + +/* + * freebsd exception handling words + * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE + * the word in ToS. If an exception happens, restore the state to what + * it was before, and pushes the exception value on the stack. If not, + * push zero. + * + * Notice that Catch implements an inner interpreter. This is ugly, + * but given how Ficl works, it cannot be helped. The problem is that + * colon definitions will be executed *after* the function returns, + * while "code" definitions will be executed immediately. I considered + * other solutions to this problem, but all of them shared the same + * basic problem (with added disadvantages): if Ficl ever changes it's + * inner thread modus operandi, one would have to fix this word. + * + * More comments can be found throughout catch's code. + * + * Daniel C. Sobral Jan 09/1999 + * sadler may 2000 -- revised to follow ficl.c:ficlExecXT. + */ +static void +ficlPrimitiveCatch(ficlVm *vm) +{ + int except; + jmp_buf vmState; + ficlVm vmCopy; + ficlStack dataStackCopy; + ficlStack returnStackCopy; + ficlWord *word; + + FICL_VM_ASSERT(vm, vm); + FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord); + + /* + * Get xt. + * We need this *before* we save the stack pointer, or + * we'll have to pop one element out of the stack after + * an exception. I prefer to get done with it up front. :-) + */ + + FICL_STACK_CHECK(vm->dataStack, 1, 0); + + word = ficlStackPopPointer(vm->dataStack); + + /* + * Save vm's state -- a catch will not back out environmental + * changes. + * + * We are *not* saving dictionary state, since it is + * global instead of per vm, and we are not saving + * stack contents, since we are not required to (and, + * thus, it would be useless). We save vm, and vm + * "stacks" (a structure containing general information + * about it, including the current stack pointer). + */ + memcpy((void*)&vmCopy, (void*)vm, sizeof (ficlVm)); + memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof (ficlStack)); + memcpy((void*)&returnStackCopy, (void*)vm->returnStack, + sizeof (ficlStack)); + + /* + * Give vm a jmp_buf + */ + vm->exceptionHandler = &vmState; + + /* + * Safety net + */ + except = setjmp(vmState); + + switch (except) { + /* + * Setup condition - push poison pill so that the VM throws + * VM_INNEREXIT if the XT terminates normally, then execute + * the XT + */ + case 0: + /* Open mouth, insert emetic */ + ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); + ficlVmExecuteWord(vm, word); + ficlVmInnerLoop(vm, 0); + break; + + /* + * Normal exit from XT - lose the poison pill, + * restore old setjmp vector and push a zero. + */ + case FICL_VM_STATUS_INNER_EXIT: + ficlVmPopIP(vm); /* Gack - hurl poison pill */ + /* Restore just the setjmp vector */ + vm->exceptionHandler = vmCopy.exceptionHandler; + /* Push 0 -- everything is ok */ + ficlStackPushInteger(vm->dataStack, 0); + break; + + /* + * Some other exception got thrown - restore pre-existing VM state + * and push the exception code + */ + default: + /* Restore vm's state */ + memcpy((void*)vm, (void*)&vmCopy, sizeof (ficlVm)); + memcpy((void*)vm->dataStack, (void*)&dataStackCopy, + sizeof (ficlStack)); + memcpy((void*)vm->returnStack, (void*)&returnStackCopy, + sizeof (ficlStack)); + + ficlStackPushInteger(vm->dataStack, except); /* Push error */ + break; + } +} + +/* + * t h r o w + * EXCEPTION + * Throw -- From ANS Forth standard. + * + * Throw takes the ToS and, if that's different from zero, + * returns to the last executed catch context. Further throws will + * unstack previously executed "catches", in LIFO mode. + * + * Daniel C. Sobral Jan 09/1999 + */ +static void +ficlPrimitiveThrow(ficlVm *vm) +{ + int except; + + except = ficlStackPopInteger(vm->dataStack); + + if (except) + ficlVmThrow(vm, except); +} + +/* + * a l l o c a t e + * MEMORY + */ +static void +ficlPrimitiveAllocate(ficlVm *vm) +{ + size_t size; + void *p; + + size = ficlStackPopInteger(vm->dataStack); + p = ficlMalloc(size); + ficlStackPushPointer(vm->dataStack, p); + if (p != NULL) + ficlStackPushInteger(vm->dataStack, 0); + else + ficlStackPushInteger(vm->dataStack, 1); +} + +/* + * f r e e + * MEMORY + */ +static void +ficlPrimitiveFree(ficlVm *vm) +{ + void *p; + + p = ficlStackPopPointer(vm->dataStack); + ficlFree(p); + ficlStackPushInteger(vm->dataStack, 0); +} + +/* + * r e s i z e + * MEMORY + */ +static void +ficlPrimitiveResize(ficlVm *vm) +{ + size_t size; + void *new, *old; + + size = ficlStackPopInteger(vm->dataStack); + old = ficlStackPopPointer(vm->dataStack); + new = ficlRealloc(old, size); + + if (new) { + ficlStackPushPointer(vm->dataStack, new); + ficlStackPushInteger(vm->dataStack, 0); + } else { + ficlStackPushPointer(vm->dataStack, old); + ficlStackPushInteger(vm->dataStack, 1); + } +} + +/* + * e x i t - i n n e r + * Signals execXT that an inner loop has completed + */ +static void +ficlPrimitiveExitInner(ficlVm *vm) +{ + ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT); +} + +#if 0 +static void +ficlPrimitiveName(ficlVm *vm) +{ + FICL_IGNORE(vm); +} +#endif + +/* + * f i c l C o m p i l e C o r e + * Builds the primitive wordset and the environment-query namespace. + */ +void +ficlSystemCompileCore(ficlSystem *system) +{ + ficlWord *interpret; + ficlDictionary *dictionary = ficlSystemGetDictionary(system); + ficlDictionary *environment = ficlSystemGetEnvironment(system); + + FICL_SYSTEM_ASSERT(system, dictionary); + FICL_SYSTEM_ASSERT(system, environment); + +#define FICL_TOKEN(token, description) +#define FICL_INSTRUCTION_TOKEN(token, description, flags) \ + ficlDictionarySetInstruction(dictionary, description, token, flags); +#include "ficltokens.h" +#undef FICL_TOKEN +#undef FICL_INSTRUCTION_TOKEN + + /* + * The Core word set + * see softcore.c for definitions of: abs bl space spaces abort" + */ + ficlDictionarySetPrimitive(dictionary, "#", ficlPrimitiveNumberSign, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "#>", + ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "#s", ficlPrimitiveNumberSignS, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "\'", ficlPrimitiveTick, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "(", ficlPrimitiveParenthesis, + FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "+loop", + ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, ".", ficlPrimitiveDot, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ".\"", + ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, ":", ficlPrimitiveColon, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ";", ficlPrimitiveSemicolonCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "<#", + ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ">body", ficlPrimitiveToBody, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ">in", ficlPrimitiveToIn, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ">number", ficlPrimitiveToNumber, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "abort", ficlPrimitiveAbort, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "accept", ficlPrimitiveAccept, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "align", ficlPrimitiveAlign, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "aligned", ficlPrimitiveAligned, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "allot", ficlPrimitiveAllot, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "base", ficlPrimitiveBase, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "begin", ficlPrimitiveBeginCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "case", ficlPrimitiveCaseCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "char", ficlPrimitiveChar, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "char+", ficlPrimitiveCharPlus, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "chars", ficlPrimitiveChars, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "constant", + ficlPrimitiveConstant, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "count", ficlPrimitiveCount, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "cr", ficlPrimitiveCR, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "create", ficlPrimitiveCreate, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "decimal", ficlPrimitiveDecimal, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "depth", ficlPrimitiveDepth, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "do", ficlPrimitiveDoCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "does>", ficlPrimitiveDoesCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "else", ficlPrimitiveElseCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "emit", ficlPrimitiveEmit, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "endcase", + ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "endof", ficlPrimitiveEndofCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "environment?", + ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "evaluate", + ficlPrimitiveEvaluate, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "execute", ficlPrimitiveExecute, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "exit", ficlPrimitiveExitCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "fallthrough", + ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "find", ficlPrimitiveCFind, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "fm/mod", + ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "here", ficlPrimitiveHere, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "hold", ficlPrimitiveHold, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "if", ficlPrimitiveIfCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "immediate", + ficlPrimitiveImmediate, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "literal", + ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "loop", ficlPrimitiveLoopCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "m*", ficlPrimitiveMStar, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "mod", ficlPrimitiveMod, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "of", ficlPrimitiveOfCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "postpone", + ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "quit", ficlPrimitiveQuit, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "recurse", + ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "repeat", + ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "s\"", + ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "sign", ficlPrimitiveSign, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "sm/rem", + ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "source", ficlPrimitiveSource, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "state", ficlPrimitiveState, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "then", ficlPrimitiveEndifCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "type", ficlPrimitiveType, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "u.", ficlPrimitiveUDot, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "um*", ficlPrimitiveUMStar, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "um/mod", + ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "until", + ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "variable", + ficlPrimitiveVariable, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "while", + ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "word", ficlPrimitiveWord, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "[", + ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "[\']", + ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "[char]", ficlPrimitiveCharCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "]", ficlPrimitiveRightBracket, + FICL_WORD_DEFAULT); + /* + * The Core Extensions word set... + * see softcore.fr for other definitions + */ + /* "#tib" */ + ficlDictionarySetPrimitive(dictionary, ".(", ficlPrimitiveDotParen, + FICL_WORD_IMMEDIATE); + /* ".r" is in softcore */ + ficlDictionarySetPrimitive(dictionary, ":noname", + ficlPrimitiveColonNoName, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "?do", ficlPrimitiveQDoCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "again", ficlPrimitiveAgainCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "c\"", + ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "hex", ficlPrimitiveHex, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "pad", ficlPrimitivePad, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "parse", ficlPrimitiveParse, + FICL_WORD_DEFAULT); + + /* + * query restore-input save-input tib u.r u> unused + * [FICL_VM_STATE_COMPILE] + */ + ficlDictionarySetPrimitive(dictionary, "refill", ficlPrimitiveRefill, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "source-id", + ficlPrimitiveSourceID, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "to", ficlPrimitiveToValue, + FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "value", ficlPrimitiveConstant, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "\\", ficlPrimitiveBackslash, + FICL_WORD_IMMEDIATE); + + /* + * Environment query values for the Core word set + */ + ficlDictionarySetConstant(environment, "/counted-string", + FICL_COUNTED_STRING_MAX); + ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE); + ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE); + ficlDictionarySetConstant(environment, "address-unit-bits", 8); + ficlDictionarySetConstant(environment, "core", FICL_TRUE); + ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE); + ficlDictionarySetConstant(environment, "floored", FICL_FALSE); + ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX); + ficlDictionarySetConstant(environment, "max-n", LONG_MAX); + ficlDictionarySetConstant(environment, "max-u", ULONG_MAX); + + { + ficl2Integer id; + ficlInteger low, high; + + low = ULONG_MAX; + high = LONG_MAX; + FICL_2INTEGER_SET(high, low, id); + ficlDictionarySet2Constant(environment, "max-d", id); + high = ULONG_MAX; + FICL_2INTEGER_SET(high, low, id); + ficlDictionarySet2Constant(environment, "max-ud", id); + } + + ficlDictionarySetConstant(environment, "return-stack-cells", + FICL_DEFAULT_STACK_SIZE); + ficlDictionarySetConstant(environment, "stack-cells", + FICL_DEFAULT_STACK_SIZE); + + /* + * The optional Double-Number word set (partial) + */ + ficlDictionarySetPrimitive(dictionary, "2constant", + ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "2literal", + ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "2variable", + ficlPrimitive2Variable, FICL_WORD_IMMEDIATE); + /* + * D+ D- D. D.R D0< D0= D2* D2/ in softcore + * D< D= D>S DABS DMAX DMIN DNEGATE in softcore + * m-star-slash is TODO + * M+ in softcore + */ + + /* + * DOUBLE EXT + */ + ficlDictionarySetPrimitive(dictionary, "2rot", + ficlPrimitive2Rot, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "2value", + ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); + /* du< in softcore */ + /* + * The optional Exception and Exception Extensions word set + */ + ficlDictionarySetPrimitive(dictionary, "catch", ficlPrimitiveCatch, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "throw", ficlPrimitiveThrow, + FICL_WORD_DEFAULT); + + ficlDictionarySetConstant(environment, "exception", FICL_TRUE); + ficlDictionarySetConstant(environment, "exception-ext", FICL_TRUE); + + /* + * The optional Locals and Locals Extensions word set + * see softcore.c for implementation of locals| + */ +#if FICL_WANT_LOCALS + ficlDictionarySetPrimitive(dictionary, "doLocal", + ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "(local)", + ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY); + ficlDictionarySetPrimitive(dictionary, "(2local)", + ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY); + + ficlDictionarySetConstant(environment, "locals", FICL_TRUE); + ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE); + ficlDictionarySetConstant(environment, "#locals", FICL_MAX_LOCALS); +#endif + + /* + * The optional Memory-Allocation word set + */ + + ficlDictionarySetPrimitive(dictionary, "allocate", + ficlPrimitiveAllocate, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "free", ficlPrimitiveFree, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "resize", ficlPrimitiveResize, + FICL_WORD_DEFAULT); + + ficlDictionarySetConstant(environment, "memory-alloc", FICL_TRUE); + + /* + * The optional Search-Order word set + */ + ficlSystemCompileSearch(system); + + /* + * The optional Programming-Tools and Programming-Tools + * Extensions word set + */ + ficlSystemCompileTools(system); + + /* + * The optional File-Access and File-Access Extensions word set + */ +#if FICL_WANT_FILE + ficlSystemCompileFile(system); +#endif + + /* + * Ficl extras + */ + ficlDictionarySetPrimitive(dictionary, ".ver", ficlPrimitiveVersion, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, ">name", ficlPrimitiveToName, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "add-parse-step", + ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "body>", ficlPrimitiveFromBody, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "compile-only", + ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "endif", ficlPrimitiveEndifCoIm, + FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "last-word", + ficlPrimitiveLastWord, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "hash", ficlPrimitiveHash, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "objectify", + ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "?object", + ficlPrimitiveIsObject, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "parse-word", + ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "sfind", ficlPrimitiveSFind, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "sliteral", + ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); + ficlDictionarySetPrimitive(dictionary, "sprintf", ficlPrimitiveSprintf, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "strlen", ficlPrimitiveStrlen, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "x.", ficlPrimitiveHexDot, + FICL_WORD_DEFAULT); +#if FICL_WANT_USER + ficlDictionarySetPrimitive(dictionary, "user", ficlPrimitiveUser, + FICL_WORD_DEFAULT); +#endif + + /* + * internal support words + */ + interpret = ficlDictionarySetPrimitive(dictionary, "interpret", + ficlPrimitiveInterpret, FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "lookup", ficlPrimitiveLookup, + FICL_WORD_DEFAULT); + ficlDictionarySetPrimitive(dictionary, "(parse-step)", + ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT); + system->exitInnerWord = ficlDictionarySetPrimitive(dictionary, + "exit-inner", ficlPrimitiveExitInner, FICL_WORD_DEFAULT); + + /* + * Set constants representing the internal instruction words + * If you want all of 'em, turn that "#if 0" to "#if 1". + * By default you only get the numbers (fi0, fiNeg1, etc). + */ +#define FICL_TOKEN(token, description) \ + ficlDictionarySetConstant(dictionary, #token, token); +#if 0 +#define FICL_INSTRUCTION_TOKEN(token, description, flags) \ + ficlDictionarySetConstant(dictionary, #token, token); +#else +#define FICL_INSTRUCTION_TOKEN(token, description, flags) +#endif /* 0 */ +#include "ficltokens.h" +#undef FICL_TOKEN +#undef FICL_INSTRUCTION_TOKEN + + /* + * Set up system's outer interpreter loop - maybe this should + * be in initSystem? + */ + system->interpreterLoop[0] = interpret; + system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen; + system->interpreterLoop[2] = (ficlWord *)(void *)(-2); + + FICL_SYSTEM_ASSERT(system, + ficlDictionaryCellsAvailable(dictionary) > 0); +} |