/******************************************************************* ** 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: words.c,v 1.17 2001/12/05 07:21:34 jsadler 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. */ /* $FreeBSD$ */ #ifdef TESTMAIN #include #include #include #include #else #include #endif #include #include "ficl.h" #include "math64.h" static void colonParen(FICL_VM *pVM); static void literalIm(FICL_VM *pVM); static int ficlParseWord(FICL_VM *pVM, STRINGINFO si); /* ** 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"; #if FICL_WANT_LOCALS static void doLocalIm(FICL_VM *pVM); static void do2LocalIm(FICL_VM *pVM); #endif /* ** 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 dict location for later branch resolution. ** The location may be either a branch target or a patch address... */ static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { PUSHPTR(dp->here); PUSHPTR(tag); return; } static void markControlTag(FICL_VM *pVM, char *tag) { PUSHPTR(tag); return; } static void matchControlTag(FICL_VM *pVM, char *tag) { char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif cp = (char *)stackPopPtr(pVM->pStack); /* ** Changed the code below to compare the pointers first (by popular demand) */ if ( (cp != tag) && strcmp(cp, tag) ) { vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag); } return; } /* ** Expect a branch target address on the param stack, ** compile a literal offset from the current dict location ** to the target address */ static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { FICL_INT offset; CELL *patchAddr; matchControlTag(pVM, tag); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif patchAddr = (CELL *)stackPopPtr(pVM->pStack); offset = patchAddr - dp->here; dictAppendCell(dp, LVALUEtoCELL(offset)); return; } /* ** Expect a branch patch address on the param stack, ** compile a literal offset from the patch location ** to the current dict location */ static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { FICL_INT offset; CELL *patchAddr; matchControlTag(pVM, tag); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif patchAddr = (CELL *)stackPopPtr(pVM->pStack); offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); return; } /* ** Match the tag to the top of the stack. If success, ** sopy "here" address into the cell whose address is next ** on the stack. Used by do..leave..loop. */ static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { CELL *patchAddr; char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif cp = stackPopPtr(pVM->pStack); /* ** Changed the comparison below to compare the pointers first (by popular demand) */ if ((cp != tag) && strcmp(cp, tag)) { vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); vmTextOut(pVM, tag, 1); } patchAddr = (CELL *)stackPopPtr(pVM->pStack); *patchAddr = LVALUEtoCELL(dp->here); return; } /************************************************************************** f i c l P a r s e N u m b e r ** Attempts to convert the NULL terminated string in the VM's pad to ** a number using the VM's current base. If successful, pushes the number ** onto the param stack and returns TRUE. Otherwise, returns FALSE. ** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See ** the standard for DOUBLE wordset. **************************************************************************/ int ficlParseNumber(FICL_VM *pVM, STRINGINFO si) { FICL_INT accum = 0; char isNeg = FALSE; char hasDP = FALSE; unsigned base = pVM->base; char *cp = SI_PTR(si); FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); unsigned ch; unsigned digit; if (count > 1) { switch (*cp) { case '-': cp++; count--; isNeg = TRUE; break; case '+': cp++; count--; isNeg = FALSE; break; default: break; } } if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */ { hasDP = TRUE; count--; } if (count == 0) /* detect "+", "-", ".", "+." etc */ return FALSE; while ((count--) && ((ch = *cp++) != '\0')) { if (!isalnum(ch)) return FALSE; digit = ch - '0'; if (digit > 9) digit = tolower(ch) - 'a' + 10; if (digit >= base) return FALSE; accum = accum * base + digit; } if (hasDP) /* simple (required) DOUBLE support */ PUSHINT(0); if (isNeg) accum = -accum; PUSHINT(accum); if (pVM->state == COMPILE) literalIm(pVM); return TRUE; } /************************************************************************** a d d & f r i e n d s ** **************************************************************************/ static void add(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif i = stackPopINT(pVM->pStack); i += stackGetTop(pVM->pStack).i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void sub(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif i = stackPopINT(pVM->pStack); i = stackGetTop(pVM->pStack).i - i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void mul(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif i = stackPopINT(pVM->pStack); i *= stackGetTop(pVM->pStack).i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void negate(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = -stackPopINT(pVM->pStack); PUSHINT(i); return; } static void ficlDiv(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif i = stackPopINT(pVM->pStack); i = stackGetTop(pVM->pStack).i / i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } /* ** slash-mod CORE ( n1 n2 -- n3 n4 ) ** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 ** differ in sign, the implementation-defined result returned will be the ** same as that returned by either the phrase ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . ** NOTE: Ficl complies with the second phrase (symmetric division) */ static void slashMod(FICL_VM *pVM) { DPINT n1; FICL_INT n2; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif n2 = stackPopINT(pVM->pStack); n1.lo = stackPopINT(pVM->pStack); i64Extend(n1); qr = m64SymmetricDivI(n1, n2); PUSHINT(qr.rem); PUSHINT(qr.quot); return; } static void onePlus(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = stackGetTop(pVM->pStack).i; i += 1; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void oneMinus(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = stackGetTop(pVM->pStack).i; i -= 1; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void twoMul(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = stackGetTop(pVM->pStack).i; i *= 2; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void twoDiv(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = stackGetTop(pVM->pStack).i; i >>= 1; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; } static void mulDiv(FICL_VM *pVM) { FICL_INT x, y, z; DPINT prod; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 1); #endif z = stackPopINT(pVM->pStack); y = stackPopINT(pVM->pStack); x = stackPopINT(pVM->pStack); prod = m64MulI(x,y); x = m64SymmetricDivI(prod, z).quot; PUSHINT(x); return; } static void mulDivRem(FICL_VM *pVM) { FICL_INT x, y, z; DPINT prod; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 2); #endif z = stackPopINT(pVM->pStack); y = stackPopINT(pVM->pStack); x = stackPopINT(pVM->pStack); prod = m64MulI(x,y); qr = m64SymmetricDivI(prod, z); PUSHINT(qr.rem); PUSHINT(qr.quot); return; } /************************************************************************** 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 COMPILE, then creates a ** new word whose name is the next word in the input stream ** and whose code is colonParen. **************************************************************************/ static void colon(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictCheckThreshold(dp); pVM->state = COMPILE; markControlTag(pVM, colonTag); dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); #if FICL_WANT_LOCALS pVM->pSys->nLocals = 0; #endif return; } /************************************************************************** c o l o n P a r e n ** This is the code that executes a colon definition. It assumes that the ** virtual machine is running a "next" loop (See the vm.c ** for its implementation of member function vmExecute()). The colon ** code simply copies the address of the first word in the list of words ** to interpret into IP after saving its old value. When we return to the ** "next" loop, the virtual machine will call the code for each word in ** turn. ** **************************************************************************/ static void colonParen(FICL_VM *pVM) { IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param); vmPushIP(pVM, tempIP); return; } /************************************************************************** s e m i c o l o n C o I m ** ** IMMEDIATE code for ";". This function sets the state to INTERPRET and ** terminates a word under compilation by appending code for "(;)" to ** the definition. TO DO: checks for leftover branch target tags on the ** return stack and complains if any are found. **************************************************************************/ static void semiParen(FICL_VM *pVM) { vmPopIP(pVM); return; } static void semicolonCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pSemiParen); matchControlTag(pVM, colonTag); #if FICL_WANT_LOCALS assert(pVM->pSys->pUnLinkParen); if (pVM->pSys->nLocals > 0) { FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); dictEmpty(pLoc, pLoc->pForthWords->size); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } pVM->pSys->nLocals = 0; #endif dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen)); pVM->state = INTERPRET; dictUnsmudge(dp); return; } /************************************************************************** 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 exitParen(FICL_VM *pVM) { vmPopIP(pVM); return; } static void exitCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pExitParen); IGNORE(pVM); #if FICL_WANT_LOCALS if (pVM->pSys->nLocals > 0) { dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } #endif dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen)); return; } /************************************************************************** c o n s t a n t P a r e n ** This is the run-time code for "constant". It simply returns the ** contents of its word's first data cell. ** **************************************************************************/ void constantParen(FICL_VM *pVM) { FICL_WORD *pFW = pVM->runningWord; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif stackPush(pVM->pStack, pFW->param[0]); return; } void twoConstParen(FICL_VM *pVM) { FICL_WORD *pFW = pVM->runningWord; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif stackPush(pVM->pStack, pFW->param[0]); /* lo */ stackPush(pVM->pStack, pFW->param[1]); /* hi */ return; } /************************************************************************** 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 constant(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif dictAppendWord2(dp, si, constantParen, FW_DEFAULT); dictAppendCell(dp, stackPop(pVM->pStack)); return; } static void twoConstant(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif c = stackPop(pVM->pStack); dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT); dictAppendCell(dp, stackPop(pVM->pStack)); dictAppendCell(dp, c); return; } /************************************************************************** d i s p l a y C e l l ** Drop and print the contents of the cell at the top of the param ** stack **************************************************************************/ static void displayCell(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif c = stackPop(pVM->pStack); ltoa((c).i, pVM->pad, pVM->base); strcat(pVM->pad, " "); vmTextOut(pVM, pVM->pad, 0); return; } static void uDot(FICL_VM *pVM) { FICL_UNS u; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif u = stackPopUNS(pVM->pStack); ultoa(u, pVM->pad, pVM->base); strcat(pVM->pad, " "); vmTextOut(pVM, pVM->pad, 0); return; } static void hexDot(FICL_VM *pVM) { FICL_UNS u; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif u = stackPopUNS(pVM->pStack); ultoa(u, pVM->pad, 16); strcat(pVM->pad, " "); vmTextOut(pVM, pVM->pad, 0); return; } /************************************************************************** s t r l e n ** FICL ( c-string -- length ) ** ** Returns the length of a C-style (zero-terminated) string. ** ** --lch **/ static void ficlStrlen(FICL_VM *ficlVM) { char *address = (char *)stackPopPtr(ficlVM->pStack); stackPushINT(ficlVM->pStack, 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 cell 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 (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 ficlSprintf(FICL_VM *pVM) /* */ { int bufferLength = stackPopINT(pVM->pStack); char *buffer = (char *)stackPopPtr(pVM->pStack); char *bufferStart = buffer; int formatLength = stackPopINT(pVM->pStack); char *format = (char *)stackPopPtr(pVM->pStack); char *formatStop = format + formatLength; int base = 10; int unsignedInteger = FALSE; FICL_INT append = FICL_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(*format); if (desiredLength) { desiredLength = strtol(format, &format, 10); if (format == formatStop) break; } else if (*format == '*') { desiredLength = stackPopINT(pVM->pStack); format++; if (format == formatStop) break; } switch (*format) { case 's': case 'S': { actualLength = stackPopINT(pVM->pStack); source = (char *)stackPopPtr(pVM->pStack); break; } case 'x': case 'X': base = 16; case 'u': case 'U': unsignedInteger = TRUE; case 'd': case 'D': { int integer = stackPopINT(pVM->pStack); if (unsignedInteger) ultoa(integer, scratch, base); else ltoa(integer, scratch, base); base = 10; unsignedInteger = FALSE; source = scratch; actualLength = strlen(scratch); break; } case '%': source = format; actualLength = 1; default: continue; } } if (append != FICL_FALSE) { if (!desiredLength) desiredLength = actualLength; if (desiredLength > bufferLength) { append = FICL_FALSE; desiredLength = bufferLength; } while (desiredLength > actualLength) { *buffer++ = (char)((leadingZeroes) ? '0' : ' '); bufferLength--; desiredLength--; } memcpy(buffer, source, actualLength); buffer += actualLength; bufferLength -= actualLength; } format++; } stackPushPtr(pVM->pStack, bufferStart); stackPushINT(pVM->pStack, buffer - bufferStart); stackPushINT(pVM->pStack, append); } /************************************************************************** d u p & f r i e n d s ** **************************************************************************/ static void depth(FICL_VM *pVM) { int i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif i = stackDepth(pVM->pStack); PUSHINT(i); return; } static void drop(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif stackDrop(pVM->pStack, 1); return; } static void twoDrop(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif stackDrop(pVM->pStack, 2); return; } static void dup(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 2); #endif stackPick(pVM->pStack, 0); return; } static void twoDup(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 4); #endif stackPick(pVM->pStack, 1); stackPick(pVM->pStack, 1); return; } static void over(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 3); #endif stackPick(pVM->pStack, 1); return; } static void twoOver(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 4, 6); #endif stackPick(pVM->pStack, 3); stackPick(pVM->pStack, 3); return; } static void pick(FICL_VM *pVM) { CELL c = stackPop(pVM->pStack); #if FICL_ROBUST > 1 vmCheckStack(pVM, c.i+1, c.i+2); #endif stackPick(pVM->pStack, c.i); return; } static void questionDup(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 2); #endif c = stackGetTop(pVM->pStack); if (c.i != 0) stackPick(pVM->pStack, 0); return; } static void roll(FICL_VM *pVM) { int i = stackPop(pVM->pStack).i; i = (i > 0) ? i : 0; #if FICL_ROBUST > 1 vmCheckStack(pVM, i+1, i+1); #endif stackRoll(pVM->pStack, i); return; } static void minusRoll(FICL_VM *pVM) { int i = stackPop(pVM->pStack).i; i = (i > 0) ? i : 0; #if FICL_ROBUST > 1 vmCheckStack(pVM, i+1, i+1); #endif stackRoll(pVM->pStack, -i); return; } static void rot(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 3); #endif stackRoll(pVM->pStack, 2); return; } static void swap(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif stackRoll(pVM->pStack, 1); return; } static void twoSwap(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 4, 4); #endif stackRoll(pVM->pStack, 3); stackRoll(pVM->pStack, 3); return; } /************************************************************************** e m i t & f r i e n d s ** **************************************************************************/ static void emit(FICL_VM *pVM) { char cp[2]; int i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif i = stackPopINT(pVM->pStack); cp[0] = (char)i; cp[1] = '\0'; vmTextOut(pVM, cp, 0); return; } static void cr(FICL_VM *pVM) { vmTextOut(pVM, "", 1); return; } static void commentLine(FICL_VM *pVM) { char *cp = vmGetInBuf(pVM); char *pEnd = vmGetInBufEnd(pVM); char ch = *cp; while ((cp != pEnd) && (ch != '\r') && (ch != '\n')) { ch = *++cp; } /* ** Cope with DOS or UNIX-style EOLs - ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, ** and point cp to next char. If EOL is \0, we're done. */ if (cp != pEnd) { cp++; if ( (cp != pEnd) && (ch != *cp) && ((*cp == '\r') || (*cp == '\n')) ) cp++; } vmUpdateTib(pVM, cp); return; } /* ** 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 commentHang(FICL_VM *pVM) { vmParseStringEx(pVM, ')', 0); return; } /************************************************************************** F E T C H & S T O R E ** **************************************************************************/ static void fetch(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pCell = (CELL *)stackPopPtr(pVM->pStack); stackPush(pVM->pStack, *pCell); return; } /* ** two-fetch CORE ( a-addr -- x1 x2 ) ** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and ** x1 at the next consecutive cell. It is equivalent to the sequence ** DUP CELL+ @ SWAP @ . */ static void twoFetch(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 2); #endif pCell = (CELL *)stackPopPtr(pVM->pStack); stackPush(pVM->pStack, *pCell++); stackPush(pVM->pStack, *pCell); swap(pVM); return; } /* ** store CORE ( x a-addr -- ) ** Store x at a-addr. */ static void store(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif pCell = (CELL *)stackPopPtr(pVM->pStack); *pCell = stackPop(pVM->pStack); } /* ** two-store CORE ( x1 x2 a-addr -- ) ** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the ** next consecutive cell. It is equivalent to the sequence ** SWAP OVER ! CELL+ ! . */ static void twoStore(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 0); #endif pCell = (CELL *)stackPopPtr(pVM->pStack); *pCell++ = stackPop(pVM->pStack); *pCell = stackPop(pVM->pStack); } static void plusStore(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif pCell = (CELL *)stackPopPtr(pVM->pStack); pCell->i += stackPop(pVM->pStack).i; } static void quadFetch(FICL_VM *pVM) { UNS32 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pw = (UNS32 *)stackPopPtr(pVM->pStack); PUSHUNS((FICL_UNS)*pw); return; } static void quadStore(FICL_VM *pVM) { UNS32 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif pw = (UNS32 *)stackPopPtr(pVM->pStack); *pw = (UNS32)(stackPop(pVM->pStack).u); } static void wFetch(FICL_VM *pVM) { UNS16 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pw = (UNS16 *)stackPopPtr(pVM->pStack); PUSHUNS((FICL_UNS)*pw); return; } static void wStore(FICL_VM *pVM) { UNS16 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif pw = (UNS16 *)stackPopPtr(pVM->pStack); *pw = (UNS16)(stackPop(pVM->pStack).u); } static void cFetch(FICL_VM *pVM) { UNS8 *pc; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pc = (UNS8 *)stackPopPtr(pVM->pStack); PUSHUNS((FICL_UNS)*pc); return; } static void cStore(FICL_VM *pVM) { UNS8 *pc; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif pc = (UNS8 *)stackPopPtr(pVM->pStack); *pc = (UNS8)(stackPop(pVM->pStack).u); } /************************************************************************** b r a n c h P a r e n ** ** Runtime for "(branch)" -- expects a literal offset in the next ** compilation address, and branches to that location. **************************************************************************/ static void branchParen(FICL_VM *pVM) { vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); return; } /************************************************************************** b r a n c h 0 ** Runtime code for "(branch0)"; pop a flag from the stack, ** branch if 0. fall through otherwise. The heart of "if" and "until". **************************************************************************/ static void branch0(FICL_VM *pVM) { FICL_UNS flag; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif flag = stackPopUNS(pVM->pStack); if (flag) { /* fall through */ vmBranchRelative(pVM, 1); } else { /* take branch (to else/endif/begin) */ vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); } return; } /************************************************************************** i f C o I m ** IMMEDIATE COMPILE-ONLY ** 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 ifCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranch0); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); markBranch(dp, pVM, origTag); dictAppendUNS(dp, 1); return; } /************************************************************************** e l s e C o I m ** ** IMMEDIATE COMPILE-ONLY ** compiles an "else"... ** 1) Compile a branch and a patch address; the address gets patched ** by "endif" to point past the "else" code. ** 2) Pop the "if" patch address ** 3) Patch the "if" branch to point to the current compile address. ** 4) Push the "else" patch address. ("endif" patches this to jump past ** the "else" code. **************************************************************************/ static void elseCoIm(FICL_VM *pVM) { CELL *patchAddr; FICL_INT offset; FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranchParen); /* (1) compile branch runtime */ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); matchControlTag(pVM, origTag); patchAddr = (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */ dictAppendUNS(dp, 1); /* (1) compile patch placeholder */ offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ return; } /************************************************************************** e n d i f C o I m ** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void endifCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); resolveForwardBranch(dp, pVM, origTag); return; } /************************************************************************** c a s e C o I m ** IMMEDIATE COMPILE-ONLY ** ** ** At 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 caseCoIm(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif PUSHUNS(0); markControlTag(pVM, caseTag); return; } /************************************************************************** e n d c a s eC o I m ** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void endcaseCoIm(FICL_VM *pVM) { FICL_UNS fixupCount; FICL_DICT *dp; CELL *patchAddr; FICL_INT offset; assert(pVM->pSys->pDrop); /* ** if the last OF ended with FALLTHROUGH, ** just add the FALLTHROUGH fixup to the ** ENDOF fixups */ if (stackGetTop(pVM->pStack).p == fallthroughTag) { matchControlTag(pVM, fallthroughTag); patchAddr = POPPTR(); matchControlTag(pVM, caseTag); fixupCount = POPUNS(); PUSHPTR(patchAddr); PUSHUNS(fixupCount + 1); markControlTag(pVM, caseTag); } matchControlTag(pVM, caseTag); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif fixupCount = POPUNS(); #if FICL_ROBUST > 1 vmCheckStack(pVM, fixupCount, 0); #endif dp = vmGetDict(pVM); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop)); while (fixupCount--) { patchAddr = (CELL *)stackPopPtr(pVM->pStack); offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); } return; } static void ofParen(FICL_VM *pVM) { FICL_UNS a, b; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif a = POPUNS(); b = stackGetTop(pVM->pStack).u; if (a == b) { /* fall through */ stackDrop(pVM->pStack, 1); vmBranchRelative(pVM, 1); } else { /* take branch to next of or endswitch */ vmBranchRelative(pVM, *(int *)(pVM->ip)); } return; } /************************************************************************** o f C o I m ** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void ofCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); CELL *fallthroughFixup = NULL; assert(pVM->pSys->pBranch0); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 3); #endif if (stackGetTop(pVM->pStack).p == fallthroughTag) { matchControlTag(pVM, fallthroughTag); fallthroughFixup = POPPTR(); } matchControlTag(pVM, caseTag); markControlTag(pVM, caseTag); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen)); markBranch(dp, pVM, ofTag); dictAppendUNS(dp, 2); if (fallthroughFixup != NULL) { FICL_INT offset = dp->here - fallthroughFixup; *fallthroughFixup = LVALUEtoCELL(offset); } return; } /************************************************************************** e n d o f C o I m ** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void endofCoIm(FICL_VM *pVM) { CELL *patchAddr; FICL_UNS fixupCount; FICL_INT offset; FICL_DICT *dp = vmGetDict(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 4, 3); #endif assert(pVM->pSys->pBranchParen); /* ensure we're in an OF, */ matchControlTag(pVM, ofTag); /* grab the address of the branch location after the OF */ patchAddr = (CELL *)stackPopPtr(pVM->pStack); /* ensure we're also in a "case" */ matchControlTag(pVM, caseTag); /* grab the current number of ENDOF fixups */ fixupCount = POPUNS(); /* compile branch runtime */ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */ PUSHPTR(dp->here); PUSHUNS(fixupCount + 1); markControlTag(pVM, caseTag); /* reserve space for the ENDOF fixup */ dictAppendUNS(dp, 2); /* and patch the original OF */ offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); } /************************************************************************** f a l l t h r o u g h C o I m ** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void fallthroughCoIm(FICL_VM *pVM) { CELL *patchAddr; FICL_INT offset; FICL_DICT *dp = vmGetDict(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 4, 3); #endif /* ensure we're in an OF, */ matchControlTag(pVM, ofTag); /* grab the address of the branch location after the OF */ patchAddr = (CELL *)stackPopPtr(pVM->pStack); /* ensure we're also in a "case" */ matchControlTag(pVM, caseTag); /* okay, here we go. put the case tag back. */ markControlTag(pVM, caseTag); /* compile branch runtime */ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* push a new FALLTHROUGH fixup and the fallthroughTag */ PUSHPTR(dp->here); markControlTag(pVM, fallthroughTag); /* reserve space for the FALLTHROUGH fixup */ dictAppendUNS(dp, 2); /* and patch the original OF */ offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); } /************************************************************************** h a s h ** hash ( c-addr u -- code) ** calculates hashcode of specified string and leaves it on the stack **************************************************************************/ static void hash(FICL_VM *pVM) { STRINGINFO si; SI_SETLEN(si, stackPopUNS(pVM->pStack)); SI_SETPTR(si, stackPopPtr(pVM->pStack)); PUSHUNS(hashHashCode(si)); return; } /************************************************************************** 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 (vmGetWord) ** Attempt to find the word in the dictionary (dictLookup) ** 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 interpret(FICL_VM *pVM) { STRINGINFO si; int i; FICL_SYSTEM *pSys; assert(pVM); pSys = pVM->pSys; si = vmGetWord0(pVM); /* ** Get next word...if out of text, we're done. */ if (si.count == 0) { vmThrow(pVM, VM_OUTOFTEXT); } /* ** Attempt to find the incoming token in the dictionary. If that fails... ** run the parse chain against the incoming token until somebody eats it. ** Otherwise emit an error message and give up. ** Although ficlParseWord could be part of the parse list, I've hard coded it ** in for robustness. ficlInitSystem adds the other default steps to the list. */ if (ficlParseWord(pVM, si)) return; for (i=0; i < FICL_MAX_PARSE_STEPS; i++) { FICL_WORD *pFW = pSys->parseList[i]; if (pFW == NULL) break; if (pFW->code == parseStepParen) { FICL_PARSE_STEP pStep; pStep = (FICL_PARSE_STEP)(pFW->param->fn); if ((*pStep)(pVM, si)) return; } else { stackPushPtr(pVM->pStack, SI_PTR(si)); stackPushUNS(pVM->pStack, SI_COUNT(si)); ficlExecXT(pVM, pFW); if (stackPopINT(pVM->pStack)) return; } } i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); return; /* back to inner interpreter */ } /************************************************************************** f i c l P a r s e W o r d ** From the standard, section 3.4 ** b) Search the dictionary name space (see 3.4.2). If a definition name ** matching the string is found: ** 1.if interpreting, perform the interpretation semantics of the definition ** (see 3.4.3.2), and continue at a); ** 2.if compiling, perform the compilation semantics of the definition ** (see 3.4.3.3), and continue at a). ** ** c) If a definition name matching the string is not found, attempt to ** convert the string to a number (see 3.4.1.3). If successful: ** 1.if interpreting, place the number on the data stack, and continue at a); ** 2.if compiling, compile code that when executed will place the number on ** the stack (see 6.1.1780 LITERAL), and continue at a); ** ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). ** ** (jws 4/01) Modified to be a FICL_PARSE_STEP **************************************************************************/ static int ficlParseWord(FICL_VM *pVM, STRINGINFO si) { FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *tempFW; #if FICL_ROBUST dictCheck(dp, pVM, 0); vmCheckStack(pVM, 0, 0); #endif #if FICL_WANT_LOCALS if (pVM->pSys->nLocals > 0) { tempFW = ficlLookupLoc(pVM->pSys, si); } else #endif tempFW = dictLookup(dp, si); if (pVM->state == INTERPRET) { if (tempFW != NULL) { if (wordIsCompileOnly(tempFW)) { vmThrowErr(pVM, "Error: Compile only!"); } vmExecute(pVM, tempFW); return (int)FICL_TRUE; } } else /* (pVM->state == COMPILE) */ { if (tempFW != NULL) { if (wordIsImmediate(tempFW)) { vmExecute(pVM, tempFW); } else { dictAppendCell(dp, LVALUEtoCELL(tempFW)); } return (int)FICL_TRUE; } } return FICL_FALSE; } /* ** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in ** INTERPRET) */ static void lookup(FICL_VM *pVM) { STRINGINFO si; SI_SETLEN(si, stackPopUNS(pVM->pStack)); SI_SETPTR(si, stackPopPtr(pVM->pStack)); stackPushINT(pVM->pStack, ficlParseWord(pVM, si)); return; } /************************************************************************** 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 parseStepParen(FICL_VM *pVM) { STRINGINFO si; FICL_WORD *pFW = pVM->runningWord; FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn); SI_SETLEN(si, stackPopINT(pVM->pStack)); SI_SETPTR(si, stackPopPtr(pVM->pStack)); PUSHINT((*pStep)(pVM, si)); return; } static void addParseStep(FICL_VM *pVM) { FICL_WORD *pStep; FICL_DICT *pd = vmGetDict(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif pStep = (FICL_WORD *)(stackPop(pVM->pStack).p); if ((pStep != NULL) && isAFiclWord(pd, pStep)) ficlAddParseStep(pVM->pSys, pStep); return; } /************************************************************************** l i t e r a l P a r e n ** ** This is the runtime for (literal). It assumes that it is part of a colon ** definition, and that the next CELL contains a value to be pushed on the ** parameter stack at runtime. This code is compiled by "literal". ** **************************************************************************/ static void literalParen(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif PUSHINT(*(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 1); return; } static void twoLitParen(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif PUSHINT(*((FICL_INT *)(pVM->ip)+1)); PUSHINT(*(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 2); return; } /************************************************************************** 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 **************************************************************************/ static void literalIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pLitParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen)); dictAppendCell(dp, stackPop(pVM->pStack)); return; } static void twoLiteralIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pTwoLitParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen)); dictAppendCell(dp, stackPop(pVM->pStack)); dictAppendCell(dp, stackPop(pVM->pStack)); return; } /************************************************************************** l o g i c a n d c o m p a r i s o n s ** **************************************************************************/ static void zeroEquals(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0); stackPush(pVM->pStack, c); return; } static void zeroLess(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0); stackPush(pVM->pStack, c); return; } static void zeroGreater(FICL_VM *pVM) { CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0); stackPush(pVM->pStack, c); return; } static void isEqual(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); PUSHINT(FICL_BOOL(x.i == y.i)); return; } static void isLess(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); PUSHINT(FICL_BOOL(x.i < y.i)); return; } static void uIsLess(FICL_VM *pVM) { FICL_UNS u1, u2; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif u2 = stackPopUNS(pVM->pStack); u1 = stackPopUNS(pVM->pStack); PUSHINT(FICL_BOOL(u1 < u2)); return; } static void isGreater(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); PUSHINT(FICL_BOOL(x.i > y.i)); return; } static void uIsGreater(FICL_VM *pVM) { FICL_UNS u1, u2; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif u2 = stackPopUNS(pVM->pStack); u1 = stackPopUNS(pVM->pStack); PUSHINT(FICL_BOOL(u1 > u2)); return; } static void bitwiseAnd(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); PUSHINT(x.i & y.i); return; } static void bitwiseOr(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); PUSHINT(x.i | y.i); return; } static void bitwiseXor(FICL_VM *pVM) { CELL x, y; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); PUSHINT(x.i ^ y.i); return; } static void bitwiseNot(FICL_VM *pVM) { CELL x; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif x = stackPop(pVM->pStack); PUSHINT(~x.i); return; } /************************************************************************** D o / L o o p ** do -- IMMEDIATE COMPILE ONLY ** Compiles code to initialize a loop: 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 COMPILE ONLY ** +loop ** Compiles code for the test part of a loop: ** compile (loop), resolve forward branch from "do", and ** copy "here" address to the "leave" address allotted by "do" ** i,j,k -- 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 cell after the loop ** limit and index are the loop control variables. ** leave -- COMPILE ONLY ** Runtime: pop the loop control variables, then pop the ** "leave" address and jump (absolute) there. **************************************************************************/ static void doCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pDoParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen)); /* ** Allot space for a pointer to the end ** of the loop - "leave" uses this... */ markBranch(dp, pVM, leaveTag); dictAppendUNS(dp, 0); /* ** Mark location of head of loop... */ markBranch(dp, pVM, doTag); return; } static void doParen(FICL_VM *pVM) { CELL index, limit; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif index = stackPop(pVM->pStack); limit = stackPop(pVM->pStack); /* copy "leave" target addr to stack */ stackPushPtr(pVM->rStack, *(pVM->ip++)); stackPush(pVM->rStack, limit); stackPush(pVM->rStack, index); return; } static void qDoCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pQDoParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen)); /* ** Allot space for a pointer to the end ** of the loop - "leave" uses this... */ markBranch(dp, pVM, leaveTag); dictAppendUNS(dp, 0); /* ** Mark location of head of loop... */ markBranch(dp, pVM, doTag); return; } static void qDoParen(FICL_VM *pVM) { CELL index, limit; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif index = stackPop(pVM->pStack); limit = stackPop(pVM->pStack); /* copy "leave" target addr to stack */ stackPushPtr(pVM->rStack, *(pVM->ip++)); if (limit.u == index.u) { vmPopIP(pVM); } else { stackPush(pVM->rStack, limit); stackPush(pVM->rStack, index); } return; } /* ** Runtime code to break out of a do..loop construct ** Drop the loop control variables; the branch address ** past "loop" is next on the return stack. */ static void leaveCo(FICL_VM *pVM) { /* almost unloop */ stackDrop(pVM->rStack, 2); /* exit */ vmPopIP(pVM); return; } static void unloopCo(FICL_VM *pVM) { stackDrop(pVM->rStack, 3); return; } static void loopCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pLoopParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; } static void plusLoopCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pPLoopParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; } static void loopParen(FICL_VM *pVM) { FICL_INT index = stackGetTop(pVM->rStack).i; FICL_INT limit = stackFetch(pVM->rStack, 1).i; index++; if (index >= limit) { stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ vmBranchRelative(pVM, 1); /* fall through the loop */ } else { /* update index, branch to loop head */ stackSetTop(pVM->rStack, LVALUEtoCELL(index)); vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); } return; } static void plusLoopParen(FICL_VM *pVM) { FICL_INT index,limit,increment; int flag; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif index = stackGetTop(pVM->rStack).i; limit = stackFetch(pVM->rStack, 1).i; increment = POP().i; index += increment; if (increment < 0) flag = (index < limit); else flag = (index >= limit); if (flag) { stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ vmBranchRelative(pVM, 1); /* fall through the loop */ } else { /* update index, branch to loop head */ stackSetTop(pVM->rStack, LVALUEtoCELL(index)); vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); } return; } static void loopICo(FICL_VM *pVM) { CELL index = stackGetTop(pVM->rStack); stackPush(pVM->pStack, index); return; } static void loopJCo(FICL_VM *pVM) { CELL index = stackFetch(pVM->rStack, 3); stackPush(pVM->pStack, index); return; } static void loopKCo(FICL_VM *pVM) { CELL index = stackFetch(pVM->rStack, 6); stackPush(pVM->pStack, index); return; } /************************************************************************** r e t u r n s t a c k ** **************************************************************************/ static void toRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif stackPush(pVM->rStack, POP()); } static void fromRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif PUSH(stackPop(pVM->rStack)); } static void fetchRStack(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif PUSH(stackGetTop(pVM->rStack)); } static void twoToR(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif stackRoll(pVM->pStack, 1); stackPush(pVM->rStack, stackPop(pVM->pStack)); stackPush(pVM->rStack, stackPop(pVM->pStack)); return; } static void twoRFrom(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif stackPush(pVM->pStack, stackPop(pVM->rStack)); stackPush(pVM->pStack, stackPop(pVM->rStack)); stackRoll(pVM->pStack, 1); return; } static void twoRFetch(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif stackPush(pVM->pStack, stackFetch(pVM->rStack, 1)); stackPush(pVM->pStack, stackFetch(pVM->rStack, 0)); return; } /************************************************************************** v a r i a b l e ** **************************************************************************/ static void variableParen(FICL_VM *pVM) { FICL_WORD *fw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif fw = pVM->runningWord; PUSHPTR(fw->param); } static void variable(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, variableParen, FW_DEFAULT); dictAllotCells(dp, 1); return; } static void twoVariable(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, variableParen, FW_DEFAULT); dictAllotCells(dp, 2); return; } /************************************************************************** b a s e & f r i e n d s ** **************************************************************************/ static void base(FICL_VM *pVM) { CELL *pBase; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif pBase = (CELL *)(&pVM->base); stackPush(pVM->pStack, LVALUEtoCELL(pBase)); return; } static void decimal(FICL_VM *pVM) { pVM->base = 10; return; } static void hex(FICL_VM *pVM) { pVM->base = 16; return; } /************************************************************************** a l l o t & f r i e n d s ** **************************************************************************/ static void allot(FICL_VM *pVM) { FICL_DICT *dp; FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif dp = vmGetDict(pVM); i = POPINT(); #if FICL_ROBUST dictCheck(dp, pVM, i); #endif dictAllot(dp, i); return; } static void here(FICL_VM *pVM) { FICL_DICT *dp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif dp = vmGetDict(pVM); PUSHPTR(dp->here); return; } static void comma(FICL_VM *pVM) { FICL_DICT *dp; CELL c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif dp = vmGetDict(pVM); c = POP(); dictAppendCell(dp, c); return; } static void cComma(FICL_VM *pVM) { FICL_DICT *dp; char c; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif dp = vmGetDict(pVM); c = (char)POPINT(); dictAppendChar(dp, c); return; } static void cells(FICL_VM *pVM) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif i = POPINT(); PUSHINT(i * (FICL_INT)sizeof (CELL)); return; } static void cellPlus(FICL_VM *pVM) { char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif cp = POPPTR(); PUSHPTR(cp + sizeof (CELL)); return; } /************************************************************************** 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 ficlTick(FICL_VM *pVM) { FICL_WORD *pFW = NULL; STRINGINFO si = vmGetWord(pVM); #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif pFW = dictLookup(vmGetDict(pVM), si); if (!pFW) { int i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); } PUSHPTR(pFW); return; } static void bracketTickCoIm(FICL_VM *pVM) { ficlTick(pVM); literalIm(pVM); return; } /************************************************************************** p o s t p o n e ** Lookup the next word in the input stream and compile code to ** insert it into definitions created by the resulting word ** (defers compilation, even of immediate words) **************************************************************************/ static void postponeCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; FICL_WORD *pComma = ficlLookup(pVM->pSys, ","); assert(pComma); ficlTick(pVM); pFW = stackGetTop(pVM->pStack).p; if (wordIsImmediate(pFW)) { dictAppendCell(dp, stackPop(pVM->pStack)); } else { literalIm(pVM); dictAppendCell(dp, LVALUEtoCELL(pComma)); } return; } /************************************************************************** e x e c u t e ** Pop an execution token (pointer to a word) off the stack and ** run it **************************************************************************/ static void execute(FICL_VM *pVM) { FICL_WORD *pFW; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif pFW = stackPopPtr(pVM->pStack); vmExecute(pVM, pFW); return; } /************************************************************************** i m m e d i a t e ** Make the most recently compiled word IMMEDIATE -- it executes even ** in compile state (most often used for control compiling words ** such as IF, THEN, etc) **************************************************************************/ static void immediate(FICL_VM *pVM) { IGNORE(pVM); dictSetImmediate(vmGetDict(pVM)); return; } static void compileOnly(FICL_VM *pVM) { IGNORE(pVM); dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0); return; } static void setObjectFlag(FICL_VM *pVM) { IGNORE(pVM); dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0); return; } static void isObject(FICL_VM *pVM) { FICL_INT flag; FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE; stackPushINT(pVM->pStack, flag); return; } static void cstringLit(FICL_VM *pVM) { FICL_STRING *sp = (FICL_STRING *)(pVM->ip); char *cp = sp->text; cp += sp->count + 1; cp = alignPtr(cp); pVM->ip = (IPTYPE)(void *)cp; stackPushPtr(pVM->pStack, sp); return; } static void cstringQuoteIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); if (pVM->state == INTERPRET) { FICL_STRING *sp = (FICL_STRING *) dp->here; vmGetString(pVM, sp, '\"'); stackPushPtr(pVM->pStack, sp); /* move HERE past string so it doesn't get overwritten. --lch */ dictAllot(dp, sp->count + sizeof(FICL_COUNT)); } else /* COMPILE state */ { dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit)); dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); dictAlign(dp); } return; } /************************************************************************** d o t Q u o t e ** IMMEDIATE word that compiles a string literal for later display ** Compile stringLit, then copy the bytes of the string from the TIB ** to the dictionary. Backpatch the count byte and align the dictionary. ** ** stringlit: Fetch the count from the dictionary, then push the address ** and count on the stack. Finally, update ip to point to the first ** aligned address after the string text. **************************************************************************/ static void stringLit(FICL_VM *pVM) { FICL_STRING *sp; FICL_COUNT count; char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 2); #endif sp = (FICL_STRING *)(pVM->ip); count = sp->count; cp = sp->text; PUSHPTR(cp); PUSHUNS(count); cp += count + 1; cp = alignPtr(cp); pVM->ip = (IPTYPE)(void *)cp; } static void dotQuoteCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pType = ficlLookup(pVM->pSys, "type"); assert(pType); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); dictAlign(dp); dictAppendCell(dp, LVALUEtoCELL(pType)); return; } static void dotParen(FICL_VM *pVM) { char *pSrc = vmGetInBuf(pVM); char *pEnd = vmGetInBufEnd(pVM); char *pDest = pVM->pad; char ch; /* ** Note: the standard does not want leading spaces skipped (apparently) */ for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) *pDest++ = ch; *pDest = '\0'; if ((pEnd != pSrc) && (ch == ')')) pSrc++; vmTextOut(pVM, pVM->pad, 0); vmUpdateTib(pVM, pSrc); return; } /************************************************************************** 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 sLiteralCoIm(FICL_VM *pVM) { FICL_DICT *dp; char *cp, *cpDest; FICL_UNS u; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif dp = vmGetDict(pVM); u = POPUNS(); cp = POPPTR(); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); cpDest = (char *) dp->here; *cpDest++ = (char) u; for (; u > 0; --u) { *cpDest++ = *cp++; } *cpDest++ = 0; dp->here = PTRtoCELL alignPtr(cpDest); return; } /************************************************************************** s t a t e ** Return the address of the VM's state member (must be sized the ** same as a CELL for this reason) **************************************************************************/ static void state(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif PUSHPTR(&pVM->state); return; } /************************************************************************** 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 createParen(FICL_VM *pVM) { CELL *pCell; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif pCell = pVM->runningWord->param; PUSHPTR(pCell+1); return; } static void create(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); dictCheckThreshold(dp); dictAppendWord2(dp, si, createParen, FW_DEFAULT); dictAllotCells(dp, 1); return; } static void doDoes(FICL_VM *pVM) { CELL *pCell; IPTYPE tempIP; #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif pCell = pVM->runningWord->param; tempIP = (IPTYPE)((*pCell).p); PUSHPTR(pCell+1); vmPushIP(pVM, tempIP); return; } static void doesParen(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); dp->smudge->code = doDoes; dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); vmPopIP(pVM); return; } static void doesCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); #if FICL_WANT_LOCALS assert(pVM->pSys->pUnLinkParen); if (pVM->pSys->nLocals > 0) { FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); dictEmpty(pLoc, pLoc->pForthWords->size); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen)); } pVM->pSys->nLocals = 0; #endif IGNORE(pVM); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen)); return; } /************************************************************************** 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 toBody(FICL_VM *pVM) { FICL_WORD *pFW; /*#$-GUY CHANGE: Added robustness.-$#*/ #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pFW = POPPTR(); PUSHPTR(pFW->param + 1); return; } /* ** from-body ficl ( a-addr -- xt ) ** Reverse effect of >body */ static void fromBody(FICL_VM *pVM) { char *ptr; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif ptr = (char *)POPPTR() - sizeof (FICL_WORD); PUSHPTR(ptr); return; } /* ** >name ficl ( xt -- c-addr u ) ** Push the address and length of a word's name given its address ** xt. */ static void toName(FICL_VM *pVM) { FICL_WORD *pFW; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 2); #endif pFW = POPPTR(); PUSHPTR(pFW->name); PUSHUNS(pFW->nName); return; } static void getLastWord(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); FICL_WORD *wp = pDict->smudge; assert(wp); vmPush(pVM, LVALUEtoCELL(wp)); return; } /************************************************************************** l b r a c k e t e t c ** **************************************************************************/ static void lbracketCoIm(FICL_VM *pVM) { pVM->state = INTERPRET; return; } static void rbracket(FICL_VM *pVM) { pVM->state = COMPILE; return; } /************************************************************************** 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 lessNumberSign(FICL_VM *pVM) { FICL_STRING *sp = PTRtoSTRING pVM->pad; sp->count = 0; return; } /* ** 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 numberSign(FICL_VM *pVM) { FICL_STRING *sp; DPUNS u; UNS16 rem; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif sp = PTRtoSTRING pVM->pad; u = u64Pop(pVM->pStack); rem = m64UMod(&u, (UNS16)(pVM->base)); sp->text[sp->count++] = digit_to_char(rem); u64Push(pVM->pStack, u); return; } /* ** 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 numberSignGreater(FICL_VM *pVM) { FICL_STRING *sp; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif sp = PTRtoSTRING pVM->pad; sp->text[sp->count] = 0; strrev(sp->text); DROP(2); PUSHPTR(sp->text); PUSHUNS(sp->count); return; } /* ** 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 cell - use it! */ static void numberSignS(FICL_VM *pVM) { FICL_STRING *sp; DPUNS u; UNS16 rem; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif sp = PTRtoSTRING pVM->pad; u = u64Pop(pVM->pStack); do { rem = m64UMod(&u, (UNS16)(pVM->base)); sp->text[sp->count++] = digit_to_char(rem); } while (u.hi || u.lo); u64Push(pVM->pStack, u); return; } /* ** 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 hold(FICL_VM *pVM) { FICL_STRING *sp; int i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif sp = PTRtoSTRING pVM->pad; i = POPINT(); sp->text[sp->count++] = (char) i; return; } /* ** 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 sign(FICL_VM *pVM) { FICL_STRING *sp; int i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif sp = PTRtoSTRING pVM->pad; i = POPINT(); if (i < 0) sp->text[sp->count++] = '-'; return; } /************************************************************************** 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 toNumber(FICL_VM *pVM) { FICL_UNS count; char *cp; DPUNS accum; FICL_UNS base = pVM->base; FICL_UNS ch; FICL_UNS digit; #if FICL_ROBUST > 1 vmCheckStack(pVM,4,4); #endif count = POPUNS(); cp = (char *)POPPTR(); accum = u64Pop(pVM->pStack); for (ch = *cp; count > 0; ch = *++cp, count--) { if (ch < '0') break; digit = ch - '0'; if (digit > 9) digit = tolower(ch) - 'a' + 10; /* ** Note: following test also catches chars between 9 and a ** because 'digit' is unsigned! */ if (digit >= base) break; accum = m64Mac(accum, base, digit); } u64Push(pVM->pStack, accum); PUSHPTR(cp); PUSHUNS(count); return; } /************************************************************************** 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 interpret. ** Display the implementation-defined system prompt if in ** interpretation state, all processing has been completed, and no ** ambiguous condition exists. **************************************************************************/ static void quit(FICL_VM *pVM) { vmThrow(pVM, VM_QUIT); return; } static void ficlAbort(FICL_VM *pVM) { vmThrow(pVM, VM_ABORT); return; } /************************************************************************** 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.) ** Implementation: if there's more text in the TIB, use it. Otherwise ** throw out for more text. Copy characters up to the max count into the ** address given, and return the number of actual characters copied. ** ** Note (sobral) this may not be the behavior you'd expect if you're ** trying to get user input at load time! **************************************************************************/ static void accept(FICL_VM *pVM) { FICL_UNS count, len; char *cp; char *pBuf, *pEnd; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif pBuf = vmGetInBuf(pVM); pEnd = vmGetInBufEnd(pVM); len = pEnd - pBuf; if (len == 0) vmThrow(pVM, VM_RESTART); /* ** Now we have something in the text buffer - use it */ count = stackPopINT(pVM->pStack); cp = stackPopPtr(pVM->pStack); len = (count < len) ? count : len; strncpy(cp, vmGetInBuf(pVM), len); pBuf += len; vmUpdateTib(pVM, pBuf); PUSHINT(len); return; } /************************************************************************** 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 align(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); IGNORE(pVM); dictAlign(dp); return; } /************************************************************************** a l i g n e d ** **************************************************************************/ static void aligned(FICL_VM *pVM) { void *addr; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,1); #endif addr = POPPTR(); PUSHPTR(alignPtr(addr)); return; } /************************************************************************** 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 beginCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); markBranch(dp, pVM, destTag); return; } static void untilCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranch0); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); resolveBackBranch(dp, pVM, destTag); return; } static void whileCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranch0); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); markBranch(dp, pVM, origTag); twoSwap(pVM); dictAppendUNS(dp, 1); return; } static void repeatCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranchParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* expect "begin" branch marker */ resolveBackBranch(dp, pVM, destTag); /* expect "while" branch marker */ resolveForwardBranch(dp, pVM, origTag); return; } static void againCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); assert(pVM->pSys->pBranchParen); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); /* expect "begin" branch marker */ resolveBackBranch(dp, pVM, destTag); return; } /************************************************************************** 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 ficlChar(FICL_VM *pVM) { STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,0,1); #endif si = vmGetWord(pVM); PUSHUNS((FICL_UNS)(si.cp[0])); return; } static void charCoIm(FICL_VM *pVM) { ficlChar(pVM); literalIm(pVM); return; } /************************************************************************** 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 charPlus(FICL_VM *pVM) { char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,1); #endif cp = POPPTR(); PUSHPTR(cp + 1); return; } /************************************************************************** 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 ficlChars(FICL_VM *pVM) { if (sizeof (char) > 1) { FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,1); #endif i = POPINT(); PUSHINT(i * sizeof (char)); } /* otherwise no-op! */ return; } #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 count(FICL_VM *pVM) { FICL_STRING *sp; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,2); #endif sp = POPPTR(); PUSHPTR(sp->text); PUSHUNS(sp->count); return; } /************************************************************************** e n v i r o n m e n t ? ** environment-query CORE ( c-addr u -- false | i*x 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 false; otherwise, the flag ** is true and the i*x returned is of the type specified in the table for ** the attribute queried. **************************************************************************/ static void environmentQ(FICL_VM *pVM) { FICL_DICT *envp; FICL_WORD *pFW; STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif envp = pVM->pSys->envp; si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); si.cp = stackPopPtr(pVM->pStack); pFW = dictLookup(envp, si); if (pFW != NULL) { vmExecute(pVM, pFW); PUSHINT(FICL_TRUE); } else { PUSHINT(FICL_FALSE); } return; } /************************************************************************** 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 interpret. ** When the parse area is empty, restore the prior input source ** specification. Other stack effects are due to the words EVALUATEd. ** **************************************************************************/ static void evaluate(FICL_VM *pVM) { FICL_UNS count; char *cp; CELL id; int result; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,0); #endif count = POPUNS(); cp = POPPTR(); IGNORE(count); id = pVM->sourceID; pVM->sourceID.i = -1; result = ficlExecC(pVM, cp, count); pVM->sourceID = id; if (result != VM_OUTOFTEXT) vmThrow(pVM, result); return; } /************************************************************************** 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: compile code to push the address and count of a string ** literal, compile the string from the input stream, and align the dict ** pointer. **************************************************************************/ static void stringQuoteIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); if (pVM->state == INTERPRET) { FICL_STRING *sp = (FICL_STRING *) dp->here; vmGetString(pVM, sp, '\"'); PUSHPTR(sp->text); PUSHUNS(sp->count); } else /* COMPILE state */ { dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit)); dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); dictAlign(dp); } return; } /************************************************************************** t y p e ** Pop count and char address from stack and print the designated string. **************************************************************************/ static void type(FICL_VM *pVM) { FICL_UNS count = stackPopUNS(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); char *pDest = (char *)ficlMalloc(count + 1); /* ** 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 (!pDest) vmThrowErr(pVM, "Error: out of memory"); strncpy(pDest, cp, count); pDest[count] = '\0'; vmTextOut(pVM, pDest, 0); ficlFree(pDest); return; } /************************************************************************** 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 ficlWord(FICL_VM *pVM) { FICL_STRING *sp; char delim; STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,1); #endif sp = (FICL_STRING *)pVM->pad; delim = (char)POPINT(); si = vmParseStringEx(pVM, delim, 1); if (SI_COUNT(si) > nPAD-1) SI_SETLEN(si, nPAD-1); sp->count = (FICL_COUNT)SI_COUNT(si); strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); /*#$-GUY CHANGE: I added this.-$#*/ sp->text[sp->count] = 0; strcat(sp->text, " "); PUSHPTR(sp); return; } /************************************************************************** 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 parseNoCopy(FICL_VM *pVM) { STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,0,2); #endif si = vmGetWord0(pVM); PUSHPTR(SI_PTR(si)); PUSHUNS(SI_COUNT(si)); return; } /************************************************************************** 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 parse(FICL_VM *pVM) { STRINGINFO si; char delim; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,2); #endif delim = (char)POPINT(); si = vmParseStringEx(pVM, delim, 0); PUSHPTR(SI_PTR(si)); PUSHUNS(SI_COUNT(si)); return; } /************************************************************************** f i l l ** CORE ( c-addr u char -- ) ** If u is greater than zero, store char in each of u consecutive ** characters of memory beginning at c-addr. **************************************************************************/ static void fill(FICL_VM *pVM) { char ch; FICL_UNS u; char *cp; #if FICL_ROBUST > 1 vmCheckStack(pVM,3,0); #endif ch = (char)POPINT(); u = POPUNS(); cp = (char *)POPPTR(); while (u > 0) { *cp++ = ch; u--; } return; } /************************************************************************** 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(FICL_VM *pVM, STRINGINFO si, void *returnForFailure) { FICL_WORD *pFW; pFW = dictLookup(vmGetDict(pVM), si); if (pFW) { PUSHPTR(pFW); PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); } else { PUSHPTR(returnForFailure); PUSHUNS(0); } return; } /************************************************************************** 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 cFind(FICL_VM *pVM) { FICL_STRING *sp; STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,2); #endif sp = POPPTR(); SI_PFS(si, sp); do_find(pVM, si, sp); } /************************************************************************** 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 sFind(FICL_VM *pVM) { STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,2); #endif si.count = stackPopINT(pVM->pStack); si.cp = stackPopPtr(pVM->pStack); do_find(pVM, si, NULL); } /************************************************************************** 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-cell signed integer. **************************************************************************/ static void fmSlashMod(FICL_VM *pVM) { DPINT d1; FICL_INT n1; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM,3,2); #endif n1 = POPINT(); d1 = i64Pop(pVM->pStack); qr = m64FlooredDivI(d1, n1); PUSHINT(qr.rem); PUSHINT(qr.quot); return; } /************************************************************************** s m S l a s h R e m ** s-m-slash-rem 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-cell signed integer. **************************************************************************/ static void smSlashRem(FICL_VM *pVM) { DPINT d1; FICL_INT n1; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM,3,2); #endif n1 = POPINT(); d1 = i64Pop(pVM->pStack); qr = m64SymmetricDivI(d1, n1); PUSHINT(qr.rem); PUSHINT(qr.quot); return; } static void ficlMod(FICL_VM *pVM) { DPINT d1; FICL_INT n1; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif n1 = POPINT(); d1.lo = POPINT(); i64Extend(d1); qr = m64SymmetricDivI(d1, n1); PUSHINT(qr.rem); return; } /************************************************************************** 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-cell unsigned integer. *************************************************************************/ static void umSlashMod(FICL_VM *pVM) { DPUNS ud; FICL_UNS u1; UNSQR qr; u1 = stackPopUNS(pVM->pStack); ud = u64Pop(pVM->pStack); qr = ficlLongDiv(ud, u1); PUSHUNS(qr.rem); PUSHUNS(qr.quot); return; } /************************************************************************** l s h i f t ** l-shift CORE ( x1 u -- x2 ) ** Perform a logical left shift of u bit-places on x1, giving x2. ** Put zeroes into the least significant bits vacated by the shift. ** An ambiguous condition exists if u is greater than or equal to the ** number of bits in a cell. ** ** r-shift CORE ( x1 u -- x2 ) ** Perform a logical right shift of u bit-places on x1, giving x2. ** Put zeroes into the most significant bits vacated by the shift. An ** ambiguous condition exists if u is greater than or equal to the ** number of bits in a cell. **************************************************************************/ static void lshift(FICL_VM *pVM) { FICL_UNS nBits; FICL_UNS x1; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif nBits = POPUNS(); x1 = POPUNS(); PUSHUNS(x1 << nBits); return; } static void rshift(FICL_VM *pVM) { FICL_UNS nBits; FICL_UNS x1; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif nBits = POPUNS(); x1 = POPUNS(); PUSHUNS(x1 >> nBits); return; } /************************************************************************** m S t a r ** m-star CORE ( n1 n2 -- d ) ** d is the signed product of n1 times n2. **************************************************************************/ static void mStar(FICL_VM *pVM) { FICL_INT n2; FICL_INT n1; DPINT d; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,2); #endif n2 = POPINT(); n1 = POPINT(); d = m64MulI(n1, n2); i64Push(pVM->pStack, d); return; } static void umStar(FICL_VM *pVM) { FICL_UNS u2; FICL_UNS u1; DPUNS ud; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,2); #endif u2 = POPUNS(); u1 = POPUNS(); ud = ficlLongMul(u1, u2); u64Push(pVM->pStack, ud); return; } /************************************************************************** m a x & m i n ** **************************************************************************/ static void ficlMax(FICL_VM *pVM) { FICL_INT n2; FICL_INT n1; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif n2 = POPINT(); n1 = POPINT(); PUSHINT((n1 > n2) ? n1 : n2); return; } static void ficlMin(FICL_VM *pVM) { FICL_INT n2; FICL_INT n1; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,1); #endif n2 = POPINT(); n1 = POPINT(); PUSHINT((n1 < n2) ? n1 : n2); return; } /************************************************************************** m o v e ** CORE ( addr1 addr2 u -- ) ** If u is greater than zero, copy the contents of u consecutive address ** units at addr1 to the u consecutive address units at addr2. After MOVE ** completes, the u consecutive address units at addr2 contain exactly ** what the u consecutive address units at addr1 contained before the move. ** NOTE! This implementation assumes that a char is the same size as ** an address unit. **************************************************************************/ static void move(FICL_VM *pVM) { FICL_UNS u; char *addr2; char *addr1; #if FICL_ROBUST > 1 vmCheckStack(pVM,3,0); #endif u = POPUNS(); addr2 = POPPTR(); addr1 = POPPTR(); if (u == 0) return; /* ** Do the copy carefully, so as to be ** correct even if the two ranges overlap */ if (addr1 >= addr2) { for (; u > 0; u--) *addr2++ = *addr1++; } else { addr2 += u-1; addr1 += u-1; for (; u > 0; u--) *addr2-- = *addr1--; } return; } /************************************************************************** r e c u r s e ** **************************************************************************/ static void recurseCoIm(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); IGNORE(pVM); dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); return; } /************************************************************************** s t o d ** s-to-d CORE ( n -- d ) ** Convert the number n to the double-cell number d with the same ** numerical value. **************************************************************************/ static void sToD(FICL_VM *pVM) { FICL_INT s; #if FICL_ROBUST > 1 vmCheckStack(pVM,1,2); #endif s = POPINT(); /* sign extend to 64 bits.. */ PUSHINT(s); PUSHINT((s < 0) ? -1 : 0); return; } /************************************************************************** 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 source(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM,0,2); #endif PUSHPTR(pVM->tib.cp); PUSHINT(vmGetInBufLen(pVM)); return; } /************************************************************************** v e r s i o n ** non-standard... **************************************************************************/ static void ficlVersion(FICL_VM *pVM) { vmTextOut(pVM, "ficl Version " FICL_VER, 1); return; } /************************************************************************** t o I n ** to-in CORE **************************************************************************/ static void toIn(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM,0,1); #endif PUSHPTR(&pVM->tib.index); return; } /************************************************************************** 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 compile. **************************************************************************/ static void colonNoName(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; STRINGINFO si; SI_SETLEN(si, 0); SI_SETPTR(si, NULL); pVM->state = COMPILE; pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); PUSHPTR(pFW); markControlTag(pVM, colonTag); return; } /************************************************************************** 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 cell ** 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 cell, and a redefinition ** (also in softcore) of "user" that defines a user word and increments ** nUser. **************************************************************************/ #if FICL_WANT_USER static void userParen(FICL_VM *pVM) { FICL_INT i = pVM->runningWord->param[0].i; PUSHPTR(&pVM->user[i]); return; } static void userVariable(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); STRINGINFO si = vmGetWord(pVM); CELL c; c = stackPop(pVM->pStack); if (c.i >= FICL_USER_CELLS) { vmThrowErr(pVM, "Error - out of user space"); } dictAppendWord2(dp, si, userParen, FW_DEFAULT); dictAppendCell(dp, c); return; } #endif /************************************************************************** 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 toValue(FICL_VM *pVM) { STRINGINFO si = vmGetWord(pVM); FICL_DICT *dp = vmGetDict(pVM); FICL_WORD *pFW; #if FICL_WANT_LOCALS if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE)) { FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); pFW = dictLookup(pLoc, si); if (pFW && (pFW->code == doLocalIm)) { dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } else if (pFW && pFW->code == do2LocalIm) { dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } } #endif assert(pVM->pSys->pStore); pFW = dictLookup(dp, si); if (!pFW) { int i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); } if (pVM->state == INTERPRET) pFW->param[0] = stackPop(pVM->pStack); else /* compile code to store to word's param */ { PUSHPTR(&pFW->param[0]); literalIm(pVM); dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore)); } return; } #if FICL_WANT_LOCALS /************************************************************************** l i n k P a r e n ** ( -- ) ** Link a frame on the return stack, reserving nCells of space for ** locals - the value of nCells is the next cell in the instruction ** stream. **************************************************************************/ static void linkParen(FICL_VM *pVM) { FICL_INT nLink = *(FICL_INT *)(pVM->ip); vmBranchRelative(pVM, 1); stackLink(pVM->rStack, nLink); return; } static void unlinkParen(FICL_VM *pVM) { stackUnlink(pVM->rStack); return; } /************************************************************************** d o L o c a l I m ** Immediate - cfa of a local while compiling - when executed, compiles ** code to fetch the value of a local given the local's index in the ** word's pfa **************************************************************************/ static void getLocalParen(FICL_VM *pVM) { FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); return; } static void toLocalParen(FICL_VM *pVM) { FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); return; } static void getLocal0(FICL_VM *pVM) { stackPush(pVM->pStack, pVM->rStack->pFrame[0]); return; } static void toLocal0(FICL_VM *pVM) { pVM->rStack->pFrame[0] = stackPop(pVM->pStack); return; } static void getLocal1(FICL_VM *pVM) { stackPush(pVM->pStack, pVM->rStack->pFrame[1]); return; } static void toLocal1(FICL_VM *pVM) { pVM->rStack->pFrame[1] = stackPop(pVM->pStack); return; } /* ** 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). */ static void doLocalIm(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); FICL_INT nLocal = pVM->runningWord->param[0].i; if (pVM->state == INTERPRET) { stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); } else { if (nLocal == 0) { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0)); } else if (nLocal == 1) { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1)); } else { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocal)); } } return; } /************************************************************************** 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. **************************************************************************/ static void localParen(FICL_VM *pVM) { FICL_DICT *pDict; STRINGINFO si; #if FICL_ROBUST > 1 vmCheckStack(pVM,2,0); #endif pDict = vmGetDict(pVM); SI_SETLEN(si, POPUNS()); SI_SETPTR(si, (char *)POPPTR()); if (SI_COUNT(si) > 0) { /* add a local to the **locals** dict and update nLocals */ FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) { vmThrowErr(pVM, "Error: out of local space"); } dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); if (pVM->pSys->nLocals == 0) { /* compile code to create a local stack frame */ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); /* save location in dictionary for #locals */ pVM->pSys->pMarkLocals = pDict->here; dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); /* compile code to initialize first local */ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0)); } else if (pVM->pSys->nLocals == 1) { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1)); } else { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen)); dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); } (pVM->pSys->nLocals)++; } else if (pVM->pSys->nLocals > 0) { /* write nLocals to (link) param area in dictionary */ *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; } return; } static void get2LocalParen(FICL_VM *pVM) { FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); return; } static void do2LocalIm(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); FICL_INT nLocal = pVM->runningWord->param[0].i; if (pVM->state == INTERPRET) { stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); } else { dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocal)); } return; } static void to2LocalParen(FICL_VM *pVM) { FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack); pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); return; } static void twoLocalParen(FICL_VM *pVM) { FICL_DICT *pDict = vmGetDict(pVM); STRINGINFO si; SI_SETLEN(si, stackPopUNS(pVM->pStack)); SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); if (SI_COUNT(si) > 0) { /* add a local to the **locals** dict and update nLocals */ FICL_DICT *pLoc = ficlGetLoc(pVM->pSys); if (pVM->pSys->nLocals >= FICL_MAX_LOCALS) { vmThrowErr(pVM, "Error: out of local space"); } dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals)); if (pVM->pSys->nLocals == 0) { /* compile code to create a local stack frame */ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen)); /* save location in dictionary for #locals */ pVM->pSys->pMarkLocals = pDict->here; dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); } dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen)); dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals)); pVM->pSys->nLocals += 2; } else if (pVM->pSys->nLocals > 0) { /* write nLocals to (link) param area in dictionary */ *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals; } return; } #endif /************************************************************************** c o m p a r e ** STRING ( c-addr1 u1 c-addr2 u2 -- n ) ** Compare the string specified by c-addr1 u1 to the string specified by ** c-addr2 u2. The strings are compared, beginning at the given addresses, ** character by character, up to the length of the shorter string or until a ** difference is found. If the two strings are identical, n is zero. If the two ** strings are identical up to the length of the shorter string, n is minus-one ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not ** identical up to the length of the shorter string, n is minus-one (-1) if the ** first non-matching character in the string specified by c-addr1 u1 has a ** lesser numeric value than the corresponding character in the string specified ** by c-addr2 u2 and one (1) otherwise. **************************************************************************/ static void compareInternal(FICL_VM *pVM, int caseInsensitive) { char *cp1, *cp2; FICL_UNS u1, u2, uMin; int n = 0; vmCheckStack(pVM, 4, 1); u2 = stackPopUNS(pVM->pStack); cp2 = (char *)stackPopPtr(pVM->pStack); u1 = stackPopUNS(pVM->pStack); cp1 = (char *)stackPopPtr(pVM->pStack); uMin = (u1 < u2)? u1 : u2; for ( ; (uMin > 0) && (n == 0); uMin--) { char c1 = *cp1++; char c2 = *cp2++; if (caseInsensitive) { c1 = (char)tolower(c1); c2 = (char)tolower(c2); } n = (int)(c1 - c2); } if (n == 0) n = (int)(u1 - u2); if (n < 0) n = -1; else if (n > 0) n = 1; PUSHINT(n); return; } static void compareString(FICL_VM *pVM) { compareInternal(pVM, FALSE); } static void compareStringInsensitive(FICL_VM *pVM) { compareInternal(pVM, TRUE); } /************************************************************************** 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 pad(FICL_VM *pVM) { stackPushPtr(pVM->pStack, pVM->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 sourceid(FICL_VM *pVM) { PUSHINT(pVM->sourceID.i); return; } /************************************************************************** r e f i l l ** CORE EXT ( -- flag ) ** Attempt to fill the input buffer from the input source, returning a 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 true. Receipt of a line containing no ** characters is considered successful. If there is no input available from ** the current input source, return false. ** When the input source is a string from EVALUATE, return false and ** perform no other action. **************************************************************************/ static void refill(FICL_VM *pVM) { FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; if (ret && (pVM->fRestart == 0)) vmThrow(pVM, VM_RESTART); PUSHINT(ret); return; } /************************************************************************** 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 ficlCatch(FICL_VM *pVM) { int except; jmp_buf vmState; FICL_VM VM; FICL_STACK pStack; FICL_STACK rStack; FICL_WORD *pFW; assert(pVM); assert(pVM->pSys->pExitInner); /* ** 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. :-) */ #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif pFW = stackPopPtr(pVM->pStack); /* ** 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 pVM, and pVM ** "stacks" (a structure containing general information ** about it, including the current stack pointer). */ memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); /* ** Give pVM a jmp_buf */ pVM->pState = &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: vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */ vmExecute(pVM, pFW); vmInnerLoop(pVM); break; /* ** Normal exit from XT - lose the poison pill, ** restore old setjmp vector and push a zero. */ case VM_INNEREXIT: vmPopIP(pVM); /* Gack - hurl poison pill */ pVM->pState = VM.pState; /* Restore just the setjmp vector */ PUSHINT(0); /* Push 0 -- everything is ok */ break; /* ** Some other exception got thrown - restore pre-existing VM state ** and push the exception code */ default: /* Restore vm's state */ memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); PUSHINT(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 ficlThrow(FICL_VM *pVM) { int except; except = stackPopINT(pVM->pStack); if (except) vmThrow(pVM, except); } /************************************************************************** ** a l l o c a t e ** MEMORY **************************************************************************/ static void ansAllocate(FICL_VM *pVM) { size_t size; void *p; size = stackPopINT(pVM->pStack); p = ficlMalloc(size); PUSHPTR(p); if (p) PUSHINT(0); else PUSHINT(1); } /************************************************************************** ** f r e e ** MEMORY **************************************************************************/ static void ansFree(FICL_VM *pVM) { void *p; p = stackPopPtr(pVM->pStack); ficlFree(p); PUSHINT(0); } /************************************************************************** ** r e s i z e ** MEMORY **************************************************************************/ static void ansResize(FICL_VM *pVM) { size_t size; void *new, *old; size = stackPopINT(pVM->pStack); old = stackPopPtr(pVM->pStack); new = ficlRealloc(old, size); if (new) { PUSHPTR(new); PUSHINT(0); } else { PUSHPTR(old); PUSHINT(1); } } /************************************************************************** ** e x i t - i n n e r ** Signals execXT that an inner loop has completed **************************************************************************/ static void ficlExitInner(FICL_VM *pVM) { vmThrow(pVM, VM_INNEREXIT); } /************************************************************************** d n e g a t e ** DOUBLE ( d1 -- d2 ) ** d2 is the negation of d1. **************************************************************************/ static void dnegate(FICL_VM *pVM) { DPINT i = i64Pop(pVM->pStack); i = m64Negate(i); i64Push(pVM->pStack, i); return; } #if 0 /************************************************************************** ** **************************************************************************/ static void funcname(FICL_VM *pVM) { IGNORE(pVM); return; } #endif /************************************************************************** f i c l W o r d C l a s s i f y ** This public function helps to classify word types for SEE ** and the deugger in tools.c. Given a pointer to a word, it returns ** a member of WOR **************************************************************************/ WORDKIND ficlWordClassify(FICL_WORD *pFW) { typedef struct { WORDKIND kind; FICL_CODE code; } CODEtoKIND; static CODEtoKIND codeMap[] = { {BRANCH, branchParen}, {COLON, colonParen}, {CONSTANT, constantParen}, {CREATE, createParen}, {DO, doParen}, {DOES, doDoes}, {IF, branch0}, {LITERAL, literalParen}, {LOOP, loopParen}, {OF, ofParen}, {PLOOP, plusLoopParen}, {QDO, qDoParen}, {CSTRINGLIT, cstringLit}, {STRINGLIT, stringLit}, #if FICL_WANT_USER {USER, userParen}, #endif {VARIABLE, variableParen}, }; #define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND)) FICL_CODE code = pFW->code; int i; for (i=0; i < nMAP; i++) { if (codeMap[i].code == code) return codeMap[i].kind; } return PRIMITIVE; } #ifdef TESTMAIN /************************************************************************** ** r a n d o m ** FICL-specific **************************************************************************/ static void ficlRandom(FICL_VM *pVM) { PUSHUNS(random()); } /************************************************************************** ** s e e d - r a n d o m ** FICL-specific **************************************************************************/ static void ficlSeedRandom(FICL_VM *pVM) { srandom(POPUNS()); } #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 ficlCompileCore(FICL_SYSTEM *pSys) { FICL_DICT *dp = pSys->dp; assert (dp); /* ** CORE word set ** see softcore.c for definitions of: abs bl space spaces abort" */ pSys->pStore = dictAppendWord(dp, "!", store, FW_DEFAULT); dictAppendWord(dp, "#", numberSign, FW_DEFAULT); dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT); dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); dictAppendWord(dp, "*", mul, FW_DEFAULT); dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); dictAppendWord(dp, "+", add, FW_DEFAULT); dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); dictAppendWord(dp, ",", comma, FW_DEFAULT); dictAppendWord(dp, "-", sub, FW_DEFAULT); dictAppendWord(dp, ".", displayCell, FW_DEFAULT); dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); dictAppendWord(dp, ":", colon, FW_DEFAULT); dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); dictAppendWord(dp, "<", isLess, FW_DEFAULT); dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); dictAppendWord(dp, "=", isEqual, FW_DEFAULT); dictAppendWord(dp, ">", isGreater, FW_DEFAULT); dictAppendWord(dp, ">body", toBody, FW_DEFAULT); dictAppendWord(dp, ">in", toIn, FW_DEFAULT); dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); dictAppendWord(dp, ">r", toRStack, FW_COMPILE); dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); dictAppendWord(dp, "@", fetch, FW_DEFAULT); dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); dictAppendWord(dp, "accept", accept, FW_DEFAULT); dictAppendWord(dp, "align", align, FW_DEFAULT); dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); dictAppendWord(dp, "allot", allot, FW_DEFAULT); dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); dictAppendWord(dp, "base", base, FW_DEFAULT); dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); dictAppendWord(dp, "c!", cStore, FW_DEFAULT); dictAppendWord(dp, "c,", cComma, FW_DEFAULT); dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED); dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); dictAppendWord(dp, "cells", cells, FW_DEFAULT); dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); dictAppendWord(dp, "constant", constant, FW_DEFAULT); dictAppendWord(dp, "count", count, FW_DEFAULT); dictAppendWord(dp, "cr", cr, FW_DEFAULT); dictAppendWord(dp, "create", create, FW_DEFAULT); dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); dictAppendWord(dp, "depth", depth, FW_DEFAULT); dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); pSys->pDrop = dictAppendWord(dp, "drop", drop, FW_DEFAULT); dictAppendWord(dp, "dup", dup, FW_DEFAULT); dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); dictAppendWord(dp, "emit", emit, FW_DEFAULT); dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED); dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED); dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); dictAppendWord(dp, "execute", execute, FW_DEFAULT); dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED); dictAppendWord(dp, "fill", fill, FW_DEFAULT); dictAppendWord(dp, "find", cFind, FW_DEFAULT); dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); dictAppendWord(dp, "here", here, FW_DEFAULT); dictAppendWord(dp, "hold", hold, FW_DEFAULT); dictAppendWord(dp, "i", loopICo, FW_COMPILE); dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); dictAppendWord(dp, "j", loopJCo, FW_COMPILE); dictAppendWord(dp, "k", loopKCo, FW_COMPILE); dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); dictAppendWord(dp, "m*", mStar, FW_DEFAULT); dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); dictAppendWord(dp, "move", move, FW_DEFAULT); dictAppendWord(dp, "negate", negate, FW_DEFAULT); dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED); dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); dictAppendWord(dp, "over", over, FW_DEFAULT); dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); dictAppendWord(dp, "quit", quit, FW_DEFAULT); dictAppendWord(dp, "r>", fromRStack, FW_COMPILE); dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE); dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); dictAppendWord(dp, "rot", rot, FW_DEFAULT); dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); dictAppendWord(dp, "sign", sign, FW_DEFAULT); dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); dictAppendWord(dp, "source", source, FW_DEFAULT); dictAppendWord(dp, "state", state, FW_DEFAULT); dictAppendWord(dp, "swap", swap, FW_DEFAULT); dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); dictAppendWord(dp, "type", type, FW_DEFAULT); dictAppendWord(dp, "u.", uDot, FW_DEFAULT); dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); dictAppendWord(dp, "u>", uIsGreater, FW_DEFAULT); dictAppendWord(dp, "um*", umStar, FW_DEFAULT); dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); dictAppendWord(dp, "variable", variable, FW_DEFAULT); dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); dictAppendWord(dp, "]", rbracket, FW_DEFAULT); /* ** CORE EXT word set... ** see softcore.fr for other definitions */ /* "#tib" */ dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE); /* ".r" */ dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); dictAppendWord(dp, "2>r", twoToR, FW_COMPILE); dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE); dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE); dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE); dictAppendWord(dp, "hex", hex, FW_DEFAULT); dictAppendWord(dp, "pad", pad, FW_DEFAULT); dictAppendWord(dp, "parse", parse, FW_DEFAULT); dictAppendWord(dp, "pick", pick, FW_DEFAULT); /* query restore-input save-input tib u.r u> unused [compile] */ dictAppendWord(dp, "roll", roll, FW_DEFAULT); dictAppendWord(dp, "refill", refill, FW_DEFAULT); dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); dictAppendWord(dp, "value", constant, FW_DEFAULT); dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); /* ** Set CORE environment query values */ ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX); ficlSetEnv(pSys, "/hold", nPAD); ficlSetEnv(pSys, "/pad", nPAD); ficlSetEnv(pSys, "address-unit-bits", 8); ficlSetEnv(pSys, "core", FICL_TRUE); ficlSetEnv(pSys, "core-ext", FICL_FALSE); ficlSetEnv(pSys, "floored", FICL_FALSE); ficlSetEnv(pSys, "max-char", UCHAR_MAX); ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff); ficlSetEnv(pSys, "max-n", 0x7fffffff); ficlSetEnv(pSys, "max-u", 0xffffffff); ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff); ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK); ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK); /* ** DOUBLE word set (partial) */ dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE); dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); /* ** EXCEPTION word set */ dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); ficlSetEnv(pSys, "exception", FICL_TRUE); ficlSetEnv(pSys, "exception-ext", FICL_TRUE); /* ** LOCAL and LOCAL EXT ** see softcore.c for implementation of locals| */ #if FICL_WANT_LOCALS pSys->pLinkParen = dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); pSys->pUnLinkParen = dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); pSys->pGetLocalParen = dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); pSys->pToLocalParen = dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); pSys->pGetLocal0 = dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); pSys->pToLocal0 = dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); pSys->pGetLocal1 = dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); pSys->pToLocal1 = dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); dictAppendWord(dp, "(local)", localParen, FW_COMPILE); pSys->pGet2LocalParen = dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); pSys->pTo2LocalParen = dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); ficlSetEnv(pSys, "locals", FICL_TRUE); ficlSetEnv(pSys, "locals-ext", FICL_TRUE); ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS); #endif /* ** Optional MEMORY-ALLOC word set */ dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT); dictAppendWord(dp, "free", ansFree, FW_DEFAULT); dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); ficlSetEnv(pSys, "memory-alloc", FICL_TRUE); /* ** optional SEARCH-ORDER word set */ ficlCompileSearch(pSys); /* ** TOOLS and TOOLS EXT */ ficlCompileTools(pSys); /* ** FILE and FILE EXT */ #if FICL_WANT_FILE ficlCompileFile(pSys); #endif /* ** Ficl extras */ #if FICL_WANT_FLOAT dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); #endif dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); dictAppendWord(dp, ">name", toName, FW_DEFAULT); dictAppendWord(dp, "add-parse-step", addParseStep, FW_DEFAULT); dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compile-only", compileOnly, FW_DEFAULT); dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT); dictAppendWord(dp, "hash", hash, FW_DEFAULT); dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT); dictAppendWord(dp, "?object", isObject, FW_DEFAULT); dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); dictAppendWord(dp, "sfind", sFind, FW_DEFAULT); dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT); dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT); dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT); dictAppendWord(dp, "q!", quadStore, FW_DEFAULT); dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); dictAppendWord(dp, "w!", wStore, FW_DEFAULT); dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); #if FICL_WANT_USER dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); dictAppendWord(dp, "user", userVariable, FW_DEFAULT); #endif #ifdef TESTMAIN dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT); dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT); #endif /* ** internal support words */ dictAppendWord(dp, "(create)", createParen, FW_COMPILE); pSys->pExitParen = dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); pSys->pSemiParen = dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); pSys->pLitParen = dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); pSys->pTwoLitParen = dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); pSys->pStringLit = dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); pSys->pCStringLit = dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE); pSys->pBranch0 = dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE); pSys->pBranchParen = dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); pSys->pDoParen = dictAppendWord(dp, "(do)", doParen, FW_COMPILE); pSys->pDoesParen = dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); pSys->pQDoParen = dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); pSys->pLoopParen = dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); pSys->pPLoopParen = dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); pSys->pInterpret = dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); dictAppendWord(dp, "lookup", lookup, FW_DEFAULT); pSys->pOfParen = dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT); dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); dictAppendWord(dp, "(parse-step)", parseStepParen, FW_DEFAULT); pSys->pExitInner = dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); /* ** Set up system's outer interpreter loop - maybe this should be in initSystem? */ pSys->pInterp[0] = pSys->pInterpret; pSys->pInterp[1] = pSys->pBranchParen; pSys->pInterp[2] = (FICL_WORD *)(void *)(-2); assert(dictCellsAvail(dp) > 0); return; }