/* * 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 /* * 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); (void) 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); (void) 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); (void) 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); (void) ficlLtoa((c).i, vm->pad, vm->base); (void) 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); (void) ficlUltoa(u, vm->pad, vm->base); (void) 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); (void) ficlUltoa(u, vm->pad, 16); (void) 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; /* FALLTHROUGH */ case 'u': case 'U': unsignedInteger = 1; /* true */ /* FALLTHROUGH */ case 'd': case 'D': { int integer; integer = ficlStackPopInteger(vm->dataStack); if (unsignedInteger) (void) ficlUltoa(integer, scratch, base); else (void) ficlLtoa(integer, scratch, base); base = 10; unsignedInteger = 0; /* false */ source = scratch; actualLength = strlen(scratch); break; } case '%': source = format; actualLength = 1; /* FALLTHROUGH */ 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" -- ) * 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) { (void) 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)); (void) 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)) (void) 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); (void) 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); (void) 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 ( "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; (void) 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); (void) 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; (void) 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 ( "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: ( "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; (void) 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) (void) strncpy(here, s, length); here[length] = '\0'; s = here; } ficlVmTextOut(vm, s); } /* * w o r d * word CORE ( char "ccc" -- 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); (void) 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 ( 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" -- 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 -- ) "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"); } (void) 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; } (void) 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 "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)); } 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)); break; } 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) \ (void) 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" */ (void) ficlDictionarySetPrimitive(dictionary, "#", ficlPrimitiveNumberSign, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "#>", ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "#s", ficlPrimitiveNumberSignS, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "\'", ficlPrimitiveTick, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "(", ficlPrimitiveParenthesis, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "+loop", ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, ".", ficlPrimitiveDot, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ".\"", ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, ":", ficlPrimitiveColon, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ";", ficlPrimitiveSemicolonCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "<#", ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ">body", ficlPrimitiveToBody, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ">in", ficlPrimitiveToIn, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ">number", ficlPrimitiveToNumber, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "abort", ficlPrimitiveAbort, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "accept", ficlPrimitiveAccept, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "align", ficlPrimitiveAlign, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "aligned", ficlPrimitiveAligned, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "allot", ficlPrimitiveAllot, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "base", ficlPrimitiveBase, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "begin", ficlPrimitiveBeginCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "case", ficlPrimitiveCaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "char", ficlPrimitiveChar, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "char+", ficlPrimitiveCharPlus, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "chars", ficlPrimitiveChars, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "constant", ficlPrimitiveConstant, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "count", ficlPrimitiveCount, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "cr", ficlPrimitiveCR, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "create", ficlPrimitiveCreate, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "decimal", ficlPrimitiveDecimal, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "depth", ficlPrimitiveDepth, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "do", ficlPrimitiveDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "does>", ficlPrimitiveDoesCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "else", ficlPrimitiveElseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "emit", ficlPrimitiveEmit, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "endcase", ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "endof", ficlPrimitiveEndofCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "environment?", ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "evaluate", ficlPrimitiveEvaluate, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "execute", ficlPrimitiveExecute, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "exit", ficlPrimitiveExitCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "fallthrough", ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "find", ficlPrimitiveCFind, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "fm/mod", ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "here", ficlPrimitiveHere, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "hold", ficlPrimitiveHold, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "if", ficlPrimitiveIfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "immediate", ficlPrimitiveImmediate, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "literal", ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "loop", ficlPrimitiveLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "m*", ficlPrimitiveMStar, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "mod", ficlPrimitiveMod, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "of", ficlPrimitiveOfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "postpone", ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "quit", ficlPrimitiveQuit, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "recurse", ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "repeat", ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "s\"", ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "sign", ficlPrimitiveSign, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "sm/rem", ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "source", ficlPrimitiveSource, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "state", ficlPrimitiveState, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "then", ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "type", ficlPrimitiveType, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "u.", ficlPrimitiveUDot, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "um*", ficlPrimitiveUMStar, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "um/mod", ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "until", ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "variable", ficlPrimitiveVariable, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "while", ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "word", ficlPrimitiveWord, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "[", ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "[\']", ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "[char]", ficlPrimitiveCharCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "]", ficlPrimitiveRightBracket, FICL_WORD_DEFAULT); /* * The Core Extensions word set... * see softcore.fr for other definitions */ /* "#tib" */ (void) ficlDictionarySetPrimitive(dictionary, ".(", ficlPrimitiveDotParen, FICL_WORD_IMMEDIATE); /* ".r" is in softcore */ (void) ficlDictionarySetPrimitive(dictionary, ":noname", ficlPrimitiveColonNoName, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "?do", ficlPrimitiveQDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "again", ficlPrimitiveAgainCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "c\"", ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "hex", ficlPrimitiveHex, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "pad", ficlPrimitivePad, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "parse", ficlPrimitiveParse, FICL_WORD_DEFAULT); /* * query restore-input save-input tib u.r u> unused * [FICL_VM_STATE_COMPILE] */ (void) ficlDictionarySetPrimitive(dictionary, "refill", ficlPrimitiveRefill, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "source-id", ficlPrimitiveSourceID, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "to", ficlPrimitiveToValue, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "value", ficlPrimitiveConstant, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "\\", ficlPrimitiveBackslash, FICL_WORD_IMMEDIATE); /* * Environment query values for the Core word set */ (void) ficlDictionarySetConstant(environment, "/counted-string", FICL_COUNTED_STRING_MAX); (void) ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE); (void) ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE); (void) ficlDictionarySetConstant(environment, "address-unit-bits", 8); (void) ficlDictionarySetConstant(environment, "core", FICL_TRUE); (void) ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE); (void) ficlDictionarySetConstant(environment, "floored", FICL_FALSE); (void) ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX); (void) ficlDictionarySetConstant(environment, "max-n", LONG_MAX); (void) ficlDictionarySetConstant(environment, "max-u", ULONG_MAX); { ficl2Integer id; ficlInteger low, high; low = ULONG_MAX; high = LONG_MAX; FICL_2INTEGER_SET(high, low, id); (void) ficlDictionarySet2Constant(environment, "max-d", id); high = ULONG_MAX; FICL_2INTEGER_SET(high, low, id); (void) ficlDictionarySet2Constant(environment, "max-ud", id); } (void) ficlDictionarySetConstant(environment, "return-stack-cells", FICL_DEFAULT_STACK_SIZE); (void) ficlDictionarySetConstant(environment, "stack-cells", FICL_DEFAULT_STACK_SIZE); /* * The optional Double-Number word set (partial) */ (void) ficlDictionarySetPrimitive(dictionary, "2constant", ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "2literal", ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE); (void) 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 */ (void) ficlDictionarySetPrimitive(dictionary, "2rot", ficlPrimitive2Rot, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "2value", ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); /* du< in softcore */ /* * The optional Exception and Exception Extensions word set */ (void) ficlDictionarySetPrimitive(dictionary, "catch", ficlPrimitiveCatch, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "throw", ficlPrimitiveThrow, FICL_WORD_DEFAULT); (void) ficlDictionarySetConstant(environment, "exception", FICL_TRUE); (void) 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 (void) ficlDictionarySetPrimitive(dictionary, "doLocal", ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "(local)", ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY); (void) ficlDictionarySetPrimitive(dictionary, "(2local)", ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY); (void) ficlDictionarySetConstant(environment, "locals", FICL_TRUE); (void) ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE); (void) ficlDictionarySetConstant(environment, "#locals", FICL_MAX_LOCALS); #endif /* * The optional Memory-Allocation word set */ (void) ficlDictionarySetPrimitive(dictionary, "allocate", ficlPrimitiveAllocate, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "free", ficlPrimitiveFree, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "resize", ficlPrimitiveResize, FICL_WORD_DEFAULT); (void) 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 */ (void) ficlDictionarySetPrimitive(dictionary, ".ver", ficlPrimitiveVersion, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, ">name", ficlPrimitiveToName, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "add-parse-step", ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "body>", ficlPrimitiveFromBody, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "compile-only", ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "endif", ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "last-word", ficlPrimitiveLastWord, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "hash", ficlPrimitiveHash, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "objectify", ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "?object", ficlPrimitiveIsObject, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "parse-word", ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "sfind", ficlPrimitiveSFind, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "sliteral", ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); (void) ficlDictionarySetPrimitive(dictionary, "sprintf", ficlPrimitiveSprintf, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "strlen", ficlPrimitiveStrlen, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "x.", ficlPrimitiveHexDot, FICL_WORD_DEFAULT); #if FICL_WANT_USER (void) ficlDictionarySetPrimitive(dictionary, "user", ficlPrimitiveUser, FICL_WORD_DEFAULT); #endif /* * internal support words */ interpret = ficlDictionarySetPrimitive(dictionary, "interpret", ficlPrimitiveInterpret, FICL_WORD_DEFAULT); (void) ficlDictionarySetPrimitive(dictionary, "lookup", ficlPrimitiveLookup, FICL_WORD_DEFAULT); (void) 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) \ (void) 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); }