Index: head/sys/boot/ficl/dict.c =================================================================== --- head/sys/boot/ficl/dict.c (revision 60958) +++ head/sys/boot/ficl/dict.c (revision 60959) @@ -1,726 +1,725 @@ /******************************************************************* ** d i c t . c ** Forth Inspired Command Language - dictionary methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 ** *******************************************************************/ /* ** This file implements the dictionary -- FICL's model of ** memory management. All FICL words are stored in the ** dictionary. A word is a named chunk of data with its ** associated code. FICL treats all words the same, even ** precompiled ones, so your words become first-class ** extensions of the language. You can even define new ** control structures. ** ** 29 jun 1998 (sadler) added variable sized hash table support */ /* $FreeBSD$ */ #ifdef TESTMAIN #include #include #include #else #include #endif #include #include "ficl.h" /* Dictionary on-demand resizing control variables */ unsigned int dictThreshold; unsigned int dictIncrease; static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si); /************************************************************************** d i c t A b o r t D e f i n i t i o n ** Abort a definition in process: reclaim its memory and unlink it ** from the dictionary list. Assumes that there is a smudged ** definition in process...otherwise does nothing. ** NOTE: this function is not smart enough to unlink a word that ** has been successfully defined (ie linked into a hash). It ** only works for defs in process. If the def has been unsmudged, ** nothing happens. **************************************************************************/ void dictAbortDefinition(FICL_DICT *pDict) { FICL_WORD *pFW; ficlLockDictionary(TRUE); pFW = pDict->smudge; if (pFW->flags & FW_SMUDGE) pDict->here = (CELL *)pFW->name; ficlLockDictionary(FALSE); return; } /************************************************************************** a l i g n P t r ** Aligns the given pointer to FICL_ALIGN address units. ** Returns the aligned pointer value. **************************************************************************/ void *alignPtr(void *ptr) { #if FICL_ALIGN > 0 char *cp; CELL c; cp = (char *)ptr + FICL_ALIGN_ADD; c.p = (void *)cp; c.u = c.u & (~FICL_ALIGN_ADD); ptr = (CELL *)c.p; #endif return ptr; } /************************************************************************** d i c t A l i g n ** Align the dictionary's free space pointer **************************************************************************/ void dictAlign(FICL_DICT *pDict) { pDict->here = alignPtr(pDict->here); } /************************************************************************** d i c t A l l o t ** Allocate or remove n chars of dictionary space, with ** checks for underrun and overrun **************************************************************************/ int dictAllot(FICL_DICT *pDict, int n) { char *cp = (char *)pDict->here; #if FICL_ROBUST if (n > 0) { if ((unsigned)n <= dictCellsAvail(pDict) * sizeof (CELL)) cp += n; else return 1; /* dict is full */ } else { n = -n; if ((unsigned)n <= dictCellsUsed(pDict) * sizeof (CELL)) cp -= n; else /* prevent underflow */ cp -= dictCellsUsed(pDict) * sizeof (CELL); } #else cp += n; #endif pDict->here = PTRtoCELL cp; return 0; } /************************************************************************** d i c t A l l o t C e l l s ** Reserve space for the requested number of cells in the ** dictionary. If nCells < 0 , removes space from the dictionary. **************************************************************************/ int dictAllotCells(FICL_DICT *pDict, int nCells) { #if FICL_ROBUST if (nCells > 0) { if (nCells <= dictCellsAvail(pDict)) pDict->here += nCells; else return 1; /* dict is full */ } else { nCells = -nCells; if (nCells <= dictCellsUsed(pDict)) pDict->here -= nCells; else /* prevent underflow */ pDict->here -= dictCellsUsed(pDict); } #else pDict->here += nCells; #endif return 0; } /************************************************************************** d i c t A p p e n d C e l l ** Append the specified cell to the dictionary **************************************************************************/ void dictAppendCell(FICL_DICT *pDict, CELL c) { *pDict->here++ = c; return; } /************************************************************************** d i c t A p p e n d C h a r ** Append the specified char to the dictionary **************************************************************************/ void dictAppendChar(FICL_DICT *pDict, char c) { char *cp = (char *)pDict->here; *cp++ = c; pDict->here = PTRtoCELL cp; return; } /************************************************************************** d i c t A p p e n d W o r d ** Create a new word in the dictionary with the specified ** name, code, and flags. Name must be NULL-terminated. **************************************************************************/ FICL_WORD *dictAppendWord(FICL_DICT *pDict, char *name, FICL_CODE pCode, UNS8 flags) { STRINGINFO si; SI_SETLEN(si, strlen(name)); SI_SETPTR(si, name); return dictAppendWord2(pDict, si, pCode, flags); } /************************************************************************** d i c t A p p e n d W o r d 2 ** Create a new word in the dictionary with the specified ** STRINGINFO, code, and flags. Does not require a NULL-terminated ** name. **************************************************************************/ FICL_WORD *dictAppendWord2(FICL_DICT *pDict, STRINGINFO si, FICL_CODE pCode, UNS8 flags) { FICL_COUNT len = (FICL_COUNT)SI_COUNT(si); char *pName; FICL_WORD *pFW; ficlLockDictionary(TRUE); /* ** NOTE: dictCopyName advances "here" as a side-effect. ** It must execute before pFW is initialized. */ pName = dictCopyName(pDict, si); pFW = (FICL_WORD *)pDict->here; pDict->smudge = pFW; pFW->hash = hashHashCode(si); pFW->code = pCode; pFW->flags = (UNS8)(flags | FW_SMUDGE); pFW->nName = (char)len; pFW->name = pName; /* ** Point "here" to first cell of new word's param area... */ pDict->here = pFW->param; if (!(flags & FW_SMUDGE)) dictUnsmudge(pDict); ficlLockDictionary(FALSE); return pFW; } /************************************************************************** d i c t A p p e n d U N S 3 2 ** Append the specified UNS32 to the dictionary **************************************************************************/ void dictAppendUNS(FICL_DICT *pDict, UNS32 u) { *pDict->here++ = LVALUEtoCELL(u); return; } /************************************************************************** d i c t C e l l s A v a i l ** Returns the number of empty cells left in the dictionary **************************************************************************/ int dictCellsAvail(FICL_DICT *pDict) { return pDict->size - dictCellsUsed(pDict); } /************************************************************************** d i c t C e l l s U s e d ** Returns the number of cells consumed in the dicionary **************************************************************************/ int dictCellsUsed(FICL_DICT *pDict) { return pDict->here - pDict->dict; } /************************************************************************** d i c t C h e c k ** Checks the dictionary for corruption and throws appropriate ** errors **************************************************************************/ void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n) { if ((n >= 0) && (dictCellsAvail(pDict) * sizeof (CELL) < n)) { vmThrowErr(pVM, "Error: dictionary full"); } if ((n <= 0) && (dictCellsUsed(pDict) * sizeof (CELL) < -n)) { vmThrowErr(pVM, "Error: dictionary underflow"); } if (pDict->nLists > FICL_DEFAULT_VOCS) { dictResetSearchOrder(pDict); vmThrowErr(pVM, "Error: search order overflow"); } else if (pDict->nLists < 0) { dictResetSearchOrder(pDict); vmThrowErr(pVM, "Error: search order underflow"); } return; } /************************************************************************** d i c t C o p y N a m e ** Copy up to nFICLNAME characters of the name specified by si into ** the dictionary starting at "here", then NULL-terminate the name, ** point "here" to the next available byte, and return the address of ** the beginning of the name. Used by dictAppendWord. ** N O T E S : ** 1. "here" is guaranteed to be aligned after this operation. ** 2. If the string has zero length, align and return "here" **************************************************************************/ static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si) { char *oldCP = (char *)pDict->here; char *cp = oldCP; char *name = SI_PTR(si); int i = SI_COUNT(si); if (i == 0) { dictAlign(pDict); return (char *)pDict->here; } if (i > nFICLNAME) i = nFICLNAME; for (; i > 0; --i) { *cp++ = *name++; } *cp++ = '\0'; pDict->here = PTRtoCELL cp; dictAlign(pDict); return oldCP; } /************************************************************************** d i c t C r e a t e ** Create and initialize a dictionary with the specified number ** of cells capacity, and no hashing (hash size == 1). **************************************************************************/ FICL_DICT *dictCreate(unsigned nCells) { return dictCreateHashed(nCells, 1); } FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash) { FICL_DICT *pDict; size_t nAlloc; nAlloc = sizeof (FICL_HASH) + nCells * sizeof (CELL) + (nHash - 1) * sizeof (FICL_WORD *); pDict = ficlMalloc(sizeof (FICL_DICT)); assert(pDict); memset(pDict, 0, sizeof (FICL_DICT)); pDict->dict = ficlMalloc(nAlloc); assert(pDict->dict); pDict->size = nCells; dictEmpty(pDict, nHash); return pDict; } /************************************************************************** d i c t D e l e t e ** Free all memory allocated for the given dictionary **************************************************************************/ void dictDelete(FICL_DICT *pDict) { assert(pDict); ficlFree(pDict); return; } /************************************************************************** d i c t E m p t y ** Empty the dictionary, reset its hash table, and reset its search order. -** Clears and (re-)creates the main hash table (pForthWords) with the -** size specified by nHash. +** Clears and (re-)creates the hash table with the size specified by nHash. **************************************************************************/ void dictEmpty(FICL_DICT *pDict, unsigned nHash) { FICL_HASH *pHash; pDict->here = pDict->dict; dictAlign(pDict); pHash = (FICL_HASH *)pDict->here; dictAllot(pDict, sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *)); pHash->size = nHash; hashReset(pHash); pDict->pForthWords = pHash; pDict->smudge = NULL; dictResetSearchOrder(pDict); return; } /************************************************************************** d i c t I n c l u d e s ** Returns TRUE iff the given pointer is within the address range of ** the dictionary. **************************************************************************/ int dictIncludes(FICL_DICT *pDict, void *p) { return ((p >= (void *) &pDict->dict) && (p < (void *)(&pDict->dict + pDict->size)) ); } /************************************************************************** d i c t L o o k u p ** Find the FICL_WORD that matches the given name and length. ** If found, returns the word's address. Otherwise returns NULL. ** Uses the search order list to search multiple wordlists. **************************************************************************/ FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si) { FICL_WORD *pFW = NULL; FICL_HASH *pHash; int i; UNS16 hashCode = hashHashCode(si); assert(pDict); ficlLockDictionary(1); for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i) { pHash = pDict->pSearch[i]; pFW = hashLookup(pHash, si, hashCode); } ficlLockDictionary(0); return pFW; } /************************************************************************** d i c t L o o k u p L o c ** Same as dictLookup, but looks in system locals dictionary first... ** Assumes locals dictionary has only one wordlist... **************************************************************************/ #if FICL_WANT_LOCALS FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si) { FICL_WORD *pFW = NULL; FICL_HASH *pHash = ficlGetLoc()->pForthWords; int i; UNS16 hashCode = hashHashCode(si); assert(pHash); assert(pDict); ficlLockDictionary(1); /* ** check the locals dict first... */ pFW = hashLookup(pHash, si, hashCode); /* ** If no joy, (!pFW) --------------------------v ** iterate over the search list in the main dict */ for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i) { pHash = pDict->pSearch[i]; pFW = hashLookup(pHash, si, hashCode); } ficlLockDictionary(0); return pFW; } #endif /************************************************************************** d i c t R e s e t S e a r c h O r d e r ** Initialize the dictionary search order list to sane state **************************************************************************/ void dictResetSearchOrder(FICL_DICT *pDict) { assert(pDict); pDict->pCompile = pDict->pForthWords; pDict->nLists = 1; pDict->pSearch[0] = pDict->pForthWords; return; } /************************************************************************** d i c t S e t F l a g s ** Changes the flags field of the most recently defined word: ** Set all bits that are ones in the set parameter, clear all bits ** that are ones in the clr parameter. Clear wins in case the same bit ** is set in both parameters. **************************************************************************/ void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr) { assert(pDict->smudge); pDict->smudge->flags |= set; pDict->smudge->flags &= ~clr; return; } /************************************************************************** d i c t S e t I m m e d i a t e ** Set the most recently defined word as IMMEDIATE **************************************************************************/ void dictSetImmediate(FICL_DICT *pDict) { assert(pDict->smudge); pDict->smudge->flags |= FW_IMMEDIATE; return; } /************************************************************************** d i c t U n s m u d g e ** Completes the definition of a word by linking it ** into the main list **************************************************************************/ void dictUnsmudge(FICL_DICT *pDict) { FICL_WORD *pFW = pDict->smudge; FICL_HASH *pHash = pDict->pCompile; assert(pHash); assert(pFW); /* ** :noname words never get linked into the list... */ if (pFW->nName > 0) hashInsertWord(pHash, pFW); pFW->flags &= ~(FW_SMUDGE); return; } /************************************************************************** d i c t W h e r e ** Returns the value of the HERE pointer -- the address ** of the next free cell in the dictionary **************************************************************************/ CELL *dictWhere(FICL_DICT *pDict) { return pDict->here; } /************************************************************************** h a s h F o r g e t ** Unlink all words in the hash that have addresses greater than or ** equal to the address supplied. Implementation factor for FORGET ** and MARKER. **************************************************************************/ void hashForget(FICL_HASH *pHash, void *where) { FICL_WORD *pWord; unsigned i; assert(pHash); assert(where); for (i = 0; i < pHash->size; i++) { pWord = pHash->table[i]; while ((void *)pWord >= where) { pWord = pWord->link; } pHash->table[i] = pWord; } return; } /************************************************************************** h a s h H a s h C o d e ** ** Generate a 16 bit hashcode from a character string using a rolling ** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds ** the name before hashing it... ** N O T E : If string has zero length, returns zero. **************************************************************************/ UNS16 hashHashCode(STRINGINFO si) { /* hashPJW */ UNS8 *cp; UNS16 code = (UNS16)si.count; UNS16 shift = 0; if (si.count == 0) return 0; for (cp = (UNS8 *)si.cp; *cp && si.count; cp++, si.count--) { code = (UNS16)((code << 4) + tolower(*cp)); shift = (UNS16)(code & 0xf000); if (shift) { code ^= (UNS16)(shift >> 8); code ^= (UNS16)shift; } } return (UNS16)code; } /************************************************************************** h a s h I n s e r t W o r d ** Put a word into the hash table using the word's hashcode as ** an index (modulo the table size). **************************************************************************/ void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW) { FICL_WORD **pList; assert(pHash); assert(pFW); if (pHash->size == 1) { pList = pHash->table; } else { pList = pHash->table + (pFW->hash % pHash->size); } pFW->link = *pList; *pList = pFW; return; } /************************************************************************** h a s h L o o k u p ** Find a name in the hash table given the hashcode and text of the name. ** Returns the address of the corresponding FICL_WORD if found, ** otherwise NULL. ** Note: outer loop on link field supports inheritance in wordlists. ** It's not part of ANS Forth - ficl only. hashReset creates wordlists ** with NULL link fields. **************************************************************************/ FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode) { FICL_COUNT nCmp = (FICL_COUNT)si.count; FICL_WORD *pFW; UNS16 hashIdx; if (nCmp > nFICLNAME) nCmp = nFICLNAME; for (; pHash != NULL; pHash = pHash->link) { if (pHash->size > 1) hashIdx = (UNS16)(hashCode % pHash->size); else /* avoid the modulo op for single threaded lists */ hashIdx = 0; for (pFW = pHash->table[hashIdx]; pFW; pFW = pFW->link) { if ( (pFW->nName == si.count) && (!strincmp(si.cp, pFW->name, nCmp)) ) return pFW; #if FICL_ROBUST assert(pFW != pFW->link); #endif } } return NULL; } /************************************************************************** h a s h R e s e t ** Initialize a FICL_HASH to empty state. **************************************************************************/ void hashReset(FICL_HASH *pHash) { unsigned i; assert(pHash); for (i = 0; i < pHash->size; i++) { pHash->table[i] = NULL; } pHash->link = NULL; return; } /************************************************************************** d i c t C h e c k T h r e s h o l d ** Verify if an increase in the dictionary size is warranted, and do it if ** so. **************************************************************************/ void dictCheckThreshold(FICL_DICT* dp) { if( dictCellsAvail(dp) < dictThreshold ) { dp->dict = ficlMalloc( dictIncrease * sizeof (CELL) ); assert(dp->dict); dp->here = dp->dict; dp->size = dictIncrease; } } Index: head/sys/boot/ficl/ficl.c =================================================================== --- head/sys/boot/ficl/ficl.c (revision 60958) +++ head/sys/boot/ficl/ficl.c (revision 60959) @@ -1,545 +1,574 @@ /******************************************************************* ** f i c l . c ** Forth Inspired Command Language - external interface ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 ** *******************************************************************/ /* ** This is an ANS Forth interpreter written in C. ** Ficl uses Forth syntax for its commands, but turns the Forth ** model on its head in other respects. ** Ficl provides facilities for interoperating ** with programs written in C: C functions can be exported to Ficl, ** and Ficl commands can be executed via a C calling interface. The ** interpreter is re-entrant, so it can be used in multiple instances ** in a multitasking system. Unlike Forth, Ficl's outer interpreter ** expects a text block as input, and returns to the caller after each ** text block, so the data pump is somewhere in external code. This ** is more like TCL than Forth. ** ** Code is written in ANSI C for portability. */ /* $FreeBSD$ */ #ifdef TESTMAIN #include #else #include #endif #include #include "ficl.h" #ifdef FICL_TRACE int ficl_trace = 0; #endif /* ** Local prototypes */ /* ** System statics ** The system builds a global dictionary during its start ** sequence. This is shared by all interpreter instances. ** Therefore only one instance can update the dictionary ** at a time. The system imports a locking function that ** you can override in order to control update access to ** the dictionary. The function is stubbed out by default, ** but you can insert one: #define FICL_MULTITHREAD 1 ** and supply your own version of ficlLockDictionary. */ static FICL_DICT *dp = NULL; static FICL_DICT *envp = NULL; #if FICL_WANT_LOCALS static FICL_DICT *localp = NULL; #endif static FICL_VM *vmList = NULL; static int defaultStack = FICL_DEFAULT_STACK; static int defaultDict = FICL_DEFAULT_DICT; /************************************************************************** f i c l I n i t S y s t e m ** Binds a global dictionary to the interpreter system. ** You specify the address and size of the allocated area. ** After that, ficl manages it. ** First step is to set up the static pointers to the area. ** Then write the "precompiled" portion of the dictionary in. ** The dictionary needs to be at least large enough to hold the ** precompiled part. Try 1K cells minimum. Use "words" to find ** out how much of the dictionary is used at any time. **************************************************************************/ void ficlInitSystem(int nDictCells) { if (dp) dictDelete(dp); if (envp) dictDelete(envp); #if FICL_WANT_LOCALS if (localp) dictDelete(localp); #endif if (nDictCells <= 0) nDictCells = defaultDict; dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE); envp = dictCreate( (unsigned)FICL_DEFAULT_ENV); #if FICL_WANT_LOCALS /* ** The locals dictionary is only searched while compiling, ** but this is where speed is most important. On the other ** hand, the dictionary gets emptied after each use of locals ** The need to balance search speed with the cost of the empty ** operation led me to select a single-threaded list... */ localp = dictCreate( (unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD); #endif ficlCompileCore(dp); return; } /************************************************************************** f i c l N e w V M ** Create a new virtual machine and link it into the system list ** of VMs for later cleanup by ficlTermSystem. If this is the first ** VM to be created, use it to compile the words in softcore.c **************************************************************************/ FICL_VM *ficlNewVM(void) { FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack); pVM->link = vmList; /* ** Borrow the first vm to build the soft words in softcore.c */ if (vmList == NULL) ficlCompileSoftCore(pVM); vmList = pVM; return pVM; } /************************************************************************** + f i c l F r e e V M +** Removes the VM in question from the system VM list and deletes the +** memory allocated to it. This is an optional call, since ficlTermSystem +** will do this cleanup for you. This function is handy if you're going to +** do a lot of dynamic creation of VMs. +**************************************************************************/ +void ficlFreeVM(FICL_VM *pVM) +{ + FICL_VM *pList = vmList; + + assert(pVM != 0); + + if (vmList == pVM) + { + vmList = vmList->link; + } + else for (pList; pList != 0; pList = pList->link) + { + if (pList->link == pVM) + { + pList->link = pVM->link; + break; + } + } + + if (pList) + vmDelete(pVM); + return; +} + + +/************************************************************************** f i c l B u i l d ** Builds a word into the dictionary. ** Preconditions: system must be initialized, and there must ** be enough space for the new word's header! Operation is ** controlled by ficlLockDictionary, so any initialization ** required by your version of the function (if you overrode ** it) must be complete at this point. ** Parameters: ** name -- duh, the name of the word ** code -- code to execute when the word is invoked - must take a single param ** pointer to a FICL_VM ** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR! ** **************************************************************************/ int ficlBuild(char *name, FICL_CODE code, char flags) { int err = ficlLockDictionary(TRUE); if (err) return err; + assert(dictCellsAvail(dp) > sizeof (FICL_WORD) / sizeof (CELL)); dictAppendWord(dp, name, code, flags); ficlLockDictionary(FALSE); return 0; } /************************************************************************** f i c l E x e c ** Evaluates a block of input text in the context of the ** specified interpreter. Emits any requested output to the ** interpreter's output function. ** ** Contains the "inner interpreter" code in a tight loop ** ** Returns one of the VM_XXXX codes defined in ficl.h: ** VM_OUTOFTEXT is the normal exit condition ** VM_ERREXIT means that the interp encountered a syntax error ** and the vm has been reset to recover (some or all ** of the text block got ignored ** VM_USEREXIT means that the user executed the "bye" command ** to shut down the interpreter. This would be a good ** time to delete the vm, etc -- or you can ignore this ** signal. **************************************************************************/ int ficlExec(FICL_VM *pVM, char *pText) { return ficlExecC(pVM, pText, -1); } int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) { static FICL_WORD *pInterp = NULL; int except; jmp_buf vmState; + jmp_buf *oldState; TIB saveTib; - FICL_VM VM; - FICL_STACK rStack; if (!pInterp) pInterp = ficlLookup("interpret"); assert(pInterp); assert(pVM); if (size < 0) size = strlen(pText); vmPushTib(pVM, pText, size, &saveTib); /* - ** Save and restore pVM and pVM->rStack to enable nested calls to ficlExec + ** Save and restore VM's jmp_buf to enable nested calls to ficlExec */ - memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); - memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); - + oldState = pVM->pState; pVM->pState = &vmState; /* This has to come before the setjmp! */ except = setjmp(vmState); switch (except) { case 0: if (pVM->fRestart) { pVM->fRestart = 0; pVM->runningWord->code(pVM); } else { /* set VM up to interpret text */ vmPushIP(pVM, &pInterp); } vmInnerLoop(pVM); break; case VM_RESTART: pVM->fRestart = 1; except = VM_OUTOFTEXT; break; case VM_OUTOFTEXT: vmPopIP(pVM); #ifdef TESTMAIN if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0)) ficlTextOut(pVM, FICL_PROMPT, 0); #endif break; case VM_USEREXIT: case VM_INNEREXIT: break; case VM_QUIT: if (pVM->state == COMPILE) { dictAbortDefinition(dp); #if FICL_WANT_LOCALS dictEmpty(localp, localp->pForthWords->size); #endif } vmQuit(pVM); break; case VM_ERREXIT: case VM_ABORT: case VM_ABORTQ: default: /* user defined exit code?? */ if (pVM->state == COMPILE) { dictAbortDefinition(dp); #if FICL_WANT_LOCALS dictEmpty(localp, localp->pForthWords->size); #endif } dictResetSearchOrder(dp); - memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); - memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); - stackReset(pVM->pStack); - pVM->base = 10; + vmReset(pVM); break; } - pVM->pState = VM.pState; + pVM->pState = oldState; vmPopTib(pVM, &saveTib); return (except); } /************************************************************************** f i c l E x e c F D ** reads in text from file fd and passes it to ficlExec() * returns VM_OUTOFTEXT on success or the ficlExec() error code on * failure. */ #define nLINEBUF 256 int ficlExecFD(FICL_VM *pVM, int fd) { char cp[nLINEBUF]; int i, nLine = 0, rval = VM_OUTOFTEXT; char ch; CELL id; id = pVM->sourceID; pVM->sourceID.i = fd; /* feed each line to ficlExec */ while (1) { int status, i; i = 0; while ((status = read(fd, &ch, 1)) > 0 && ch != '\n') cp[i++] = ch; nLine++; if (!i) { if (status < 1) break; continue; } rval = ficlExecC(pVM, cp, i); if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT) { pVM->sourceID = id; return rval; } } /* ** Pass an empty line with SOURCE-ID == 0 to flush ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; ficlExec(pVM, ""); pVM->sourceID = id; return rval; } /************************************************************************** f i c l E x e c X T ** Given a pointer to a FICL_WORD, push an inner interpreter and ** execute the word to completion. This is in contrast with vmExecute, ** which does not guarantee that the word will have completed when ** the function returns (ie in the case of colon definitions, which ** need an inner interpreter to finish) ** ** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal ** exit condition is VM_INNEREXIT, ficl's private signal to exit the ** inner loop under normal circumstances. If another code is thrown to ** exit the loop, this function will re-throw it if it's nested under ** itself or ficlExec. ** ** NOTE: this function is intended so that C code can execute ficlWords ** given their address in the dictionary (xt). **************************************************************************/ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) { static FICL_WORD *pQuit = NULL; int except; jmp_buf vmState; jmp_buf *oldState; if (!pQuit) pQuit = ficlLookup("exit-inner"); assert(pVM); assert(pQuit); /* ** Save and restore VM's jmp_buf to enable nested calls */ oldState = pVM->pState; pVM->pState = &vmState; /* This has to come before the setjmp! */ except = setjmp(vmState); if (except) vmPopIP(pVM); else vmPushIP(pVM, &pQuit); switch (except) { case 0: vmExecute(pVM, pWord); vmInnerLoop(pVM); break; case VM_INNEREXIT: break; case VM_RESTART: case VM_OUTOFTEXT: case VM_USEREXIT: case VM_QUIT: case VM_ERREXIT: case VM_ABORT: case VM_ABORTQ: default: /* user defined exit code?? */ if (oldState) { pVM->pState = oldState; vmThrow(pVM, except); } break; - } + } pVM->pState = oldState; return (except); } /************************************************************************** f i c l L o o k u p ** Look in the system dictionary for a match to the given name. If ** found, return the address of the corresponding FICL_WORD. Otherwise ** return NULL. **************************************************************************/ FICL_WORD *ficlLookup(char *name) { STRINGINFO si; SI_PSZ(si, name); return dictLookup(dp, si); } /************************************************************************** f i c l G e t D i c t ** Returns the address of the system dictionary **************************************************************************/ FICL_DICT *ficlGetDict(void) { return dp; } /************************************************************************** f i c l G e t E n v ** Returns the address of the system environment space **************************************************************************/ FICL_DICT *ficlGetEnv(void) { return envp; } /************************************************************************** f i c l S e t E n v ** Create an environment variable with a one-CELL payload. ficlSetEnvD ** makes one with a two-CELL payload. **************************************************************************/ void ficlSetEnv(char *name, FICL_UNS value) { STRINGINFO si; FICL_WORD *pFW; SI_PSZ(si, name); pFW = dictLookup(envp, si); if (pFW == NULL) { dictAppendWord(envp, name, constantParen, FW_DEFAULT); dictAppendCell(envp, LVALUEtoCELL(value)); } else { pFW->param[0] = LVALUEtoCELL(value); } return; } void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) { FICL_WORD *pFW; STRINGINFO si; SI_PSZ(si, name); pFW = dictLookup(envp, si); if (pFW == NULL) { dictAppendWord(envp, name, twoConstParen, FW_DEFAULT); dictAppendCell(envp, LVALUEtoCELL(lo)); dictAppendCell(envp, LVALUEtoCELL(hi)); } else { pFW->param[0] = LVALUEtoCELL(lo); pFW->param[1] = LVALUEtoCELL(hi); } return; } /************************************************************************** f i c l G e t L o c ** Returns the address of the system locals dictionary. This dict is ** only used during compilation, and is shared by all VMs. **************************************************************************/ #if FICL_WANT_LOCALS FICL_DICT *ficlGetLoc(void) { return localp; } #endif /************************************************************************** f i c l S e t S t a c k S i z e ** Set the stack sizes (return and parameter) to be used for all ** subsequently created VMs. Returns actual stack size to be used. **************************************************************************/ int ficlSetStackSize(int nStackCells) { if (nStackCells >= FICL_DEFAULT_STACK) defaultStack = nStackCells; else defaultStack = FICL_DEFAULT_STACK; return defaultStack; } /************************************************************************** f i c l T e r m S y s t e m ** Tear the system down by deleting the dictionaries and all VMs. ** This saves you from having to keep track of all that stuff. **************************************************************************/ void ficlTermSystem(void) { if (dp) dictDelete(dp); dp = NULL; if (envp) dictDelete(envp); envp = NULL; #if FICL_WANT_LOCALS if (localp) dictDelete(localp); localp = NULL; #endif while (vmList != NULL) { FICL_VM *pVM = vmList; vmList = vmList->link; vmDelete(pVM); } return; } + + Index: head/sys/boot/ficl/ficl.h =================================================================== --- head/sys/boot/ficl/ficl.h (revision 60958) +++ head/sys/boot/ficl/ficl.h (revision 60959) @@ -1,853 +1,869 @@ /******************************************************************* ** f i c l . h ** Forth Inspired Command Language ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 ** *******************************************************************/ /* ** N O T I C E -- DISCLAIMER OF WARRANTY ** ** Ficl is freeware. Use it in any way that you like, with ** the understanding that the code is supported on a "best effort" ** basis only. ** ** Any third party may reproduce, distribute, or modify the ficl ** software code or any derivative works thereof without any ** compensation or license, provided that the author information ** and this disclaimer text are retained in the source code files. ** The ficl software code is provided on an "as is" basis without ** warranty of any kind, including, without limitation, the implied ** warranties of merchantability and fitness for a particular purpose ** and their equivalents under the laws of any jurisdiction. ** ** 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 (yay!), please ** send me email at the address above. */ /* $FreeBSD$ */ #if !defined (__FICL_H__) #define __FICL_H__ /* ** Ficl (Forth-inspired command language) is an ANS Forth ** interpreter written in C. Unlike traditional Forths, this ** interpreter is designed to be embedded into other systems ** as a command/macro/development prototype language. ** ** Where Forths usually view themselves as the center of the system ** and expect the rest of the system to be coded in Forth, Ficl ** acts as a component of the system. It is easy to export ** code written in C or ASM to Ficl in the style of TCL, or to invoke ** Ficl code from a compiled module. This allows you to do incremental ** development in a way that combines the best features of threaded ** languages (rapid development, quick code/test/debug cycle, ** reasonably fast) with the best features of C (everyone knows it, ** easier to support large blocks of code, efficient, type checking). ** ** Ficl provides facilities for interoperating ** with programs written in C: C functions can be exported to Ficl, ** and Ficl commands can be executed via a C calling interface. The ** interpreter is re-entrant, so it can be used in multiple instances ** in a multitasking system. Unlike Forth, Ficl's outer interpreter ** expects a text block as input, and returns to the caller after each ** text block, so the "data pump" is somewhere in external code. This ** is more like TCL than Forth, which usually expcets to be at the center ** of the system, requesting input at its convenience. Each Ficl virtual ** machine can be bound to a different I/O channel, and is independent ** of all others in in the same address space except that all virtual ** machines share a common dictionary (a sort or open symbol table that ** defines all of the elements of the language). ** ** Code is written in ANSI C for portability. ** ** Summary of Ficl features and constraints: ** - Standard: Implements the ANSI Forth CORE word set and part ** of the CORE EXT word-set, SEARCH and SEARCH EXT, TOOLS and ** TOOLS EXT, LOCAL and LOCAL ext and various extras. ** - Extensible: you can export code written in Forth, C, ** or asm in a straightforward way. Ficl provides open ** facilities for extending the language in an application ** specific way. You can even add new control structures! ** - Ficl and C can interact in two ways: Ficl can encapsulate ** C code, or C code can invoke Ficl code. ** - Thread-safe, re-entrant: The shared system dictionary ** uses a locking mechanism that you can either supply ** or stub out to provide exclusive access. Each Ficl ** virtual machine has an otherwise complete state, and ** each can be bound to a separate I/O channel (or none at all). ** - Simple encapsulation into existing systems: a basic implementation ** requires three function calls (see the example program in testmain.c). ** - ROMable: Ficl is designed to work in RAM-based and ROM code / RAM data ** environments. It does require somewhat more memory than a pure ** ROM implementation because it builds its system dictionary in ** RAM at startup time. ** - Written an ANSI C to be as simple as I can make it to understand, ** support, debug, and port. Compiles without complaint at /Az /W4 ** (require ANSI C, max warnings) under Microsoft VC++ 5. ** - Does full 32 bit math (but you need to implement ** two mixed precision math primitives (see sysdep.c)) ** - Indirect threaded interpreter is not the fastest kind of ** Forth there is (see pForth 68K for a really fast subroutine ** threaded interpreter), but it's the cleanest match to a ** pure C implementation. ** ** P O R T I N G F i c l ** ** To install Ficl on your target system, you need an ANSI C compiler ** and its runtime library. Inspect the system dependent macros and ** functions in sysdep.h and sysdep.c and edit them to suit your ** system. For example, INT16 is a short on some compilers and an ** int on others. Check the default CELL alignment controlled by ** FICL_ALIGN. If necessary, add new definitions of ficlMalloc, ficlFree, ** ficlLockDictionary, and ficlTextOut to work with your operating system. ** Finally, use testmain.c as a guide to installing the Ficl system and ** one or more virtual machines into your code. You do not need to include ** testmain.c in your build. ** ** T o D o L i s t ** ** 1. Unimplemented system dependent CORE word: key ** 2. Kludged CORE word: ACCEPT ** 3. Dictionary locking is full of holes - only one vm at a time ** can alter the dict. ** 4. Ficl uses the pad in CORE words - this violates the standard, ** but it's cleaner for a multithreaded system. I'll have to make a ** second pad for reference by the word PAD to fix this. ** ** F o r M o r e I n f o r m a t i o n ** ** Web home of ficl ** http://www.taygeta.com/forth/compilers ** Check this website for Forth literature (including the ANSI standard) ** http://www.taygeta.com/forthlit.html ** and here for software and more links ** http://www.taygeta.com/forth.html ** ** Obvious Performance enhancement opportunities ** Compile speed ** - work on interpret speed ** - turn off locals (FICL_WANT_LOCALS) ** Interpret speed ** - Change inner interpreter (and everything else) ** so that a definition is a list of pointers to functions ** and inline data rather than pointers to words. This gets ** rid of vm->runningWord and a level of indirection in the ** inner loop. I'll look at it for ficl 3.0 ** - Make the main hash table a bigger prime (HASHSIZE) ** - FORGET about twiddling the hash function - my experience is ** that that is a waste of time. ** - eliminate the need to pass the pVM parameter on the stack ** by dedicating a register to it. Most words need access to the ** vm, but the parameter passing overhead can be reduced. One way ** requires that the host OS have a task switch callout. Create ** a global variable for the running VM and refer to it in words ** that need VM access. Alternative: use thread local storage. ** For single threaded implementations, you can just use a global. ** The first two solutions create portability problems, so I ** haven't considered doing them. Another possibility is to ** declare the pVm parameter to be "register", and hope the compiler ** pays attention. ** */ /* ** Revision History: ** ** 15 Apr 1999 (sadler) Merged FreeBSD changes for exception wordset and ** counted strings in ficlExec. ** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an ** "end" field, and all words respect this. ficlExec is passed a "size" ** of TIB, as well as vmPushTib. This size is used to calculate the "end" ** of the string, ie, base+size. If the size is not known, pass -1. ** ** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing ** words has been modified to conform to EXCEPTION EXT word set. ** ** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT, ** SEARCH / SEARCH EXT, TOOLS / TOOLS EXT. ** Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD, ** EMPTY to clear stack. ** ** 29 jun 1998 (sadler) added variable sized hash table support ** and ANS Forth optional SEARCH & SEARCH EXT word set. ** 26 May 1998 (sadler) ** FICL_PROMPT macro ** 14 April 1998 (sadler) V1.04 ** Ficlwin: Windows version, Skip Carter's Linux port ** 5 March 1998 (sadler) V1.03 ** Bug fixes -- passes John Ryan's ANS test suite "core.fr" ** ** 24 February 1998 (sadler) V1.02 ** -Fixed bugs in <# # #> ** -Changed FICL_WORD so that storage for the name characters ** can be allocated from the dictionary as needed rather than ** reserving 32 bytes in each word whether needed or not - ** this saved 50% of the dictionary storage requirement. ** -Added words in testmain for Win32 functions system,chdir,cwd, ** also added a word that loads and evaluates a file. ** ** December 1997 (sadler) ** -Added VM_RESTART exception handling in ficlExec -- this lets words ** that require additional text to succeed (like :, create, variable...) ** recover gracefully from an empty input buffer rather than emitting ** an error message. Definitions can span multiple input blocks with ** no restrictions. ** -Changed #include order so that is included in sysdep.h, ** and sysdep is included in all other files. This lets you define ** NDEBUG in sysdep.h to disable assertions if you want to. ** -Make PC specific system dependent code conditional on _M_IX86 ** defined so that ports can coexist in sysdep.h/sysdep.c */ #ifdef __cplusplus extern "C" { #endif #include "sysdep.h" #include /* UCHAR_MAX */ /* ** Forward declarations... read on. */ struct ficl_word; struct vm; struct ficl_dict; /* ** the Good Stuff starts here... */ #define FICL_VER "2.03" #if !defined (FICL_PROMPT) #define FICL_PROMPT "ok> " #endif /* ** ANS Forth requires false to be zero, and true to be the ones ** complement of false... that unifies logical and bitwise operations ** nicely. */ #define FICL_TRUE (~(0L)) #define FICL_FALSE (0) #define FICL_BOOL(x) ((x) ? FICL_TRUE : FICL_FALSE) /* ** A CELL is the main storage type. It must be large enough ** to contain a pointer or a scalar. In order to accommodate ** 32 bit and 64 bit processors, use abstract types for i and u. */ typedef union _cell { FICL_INT i; FICL_UNS u; void *p; } CELL; /* ** LVALUEtoCELL does a little pointer trickery to cast any 32 bit ** lvalue (informal definition: an expression whose result has an ** address) to CELL. Remember that constants and casts are NOT ** themselves lvalues! */ #define LVALUEtoCELL(v) (*(CELL *)&v) /* ** PTRtoCELL is a cast through void * intended to satisfy the ** most outrageously pedantic compiler... (I won't mention ** its name) */ #define PTRtoCELL (CELL *)(void *) #define PTRtoSTRING (FICL_STRING *)(void *) /* ** Strings in FICL are stored in Pascal style - with a count ** preceding the text. We'll also NULL-terminate them so that ** they work with the usual C lib string functions. (Belt & ** suspenders? You decide.) ** STRINGINFO hides the implementation with a couple of ** macros for use in internal routines. */ typedef unsigned char FICL_COUNT; #define FICL_STRING_MAX UCHAR_MAX typedef struct _ficl_string { FICL_COUNT count; char text[1]; } FICL_STRING; typedef struct { UNS32 count; char *cp; } STRINGINFO; #define SI_COUNT(si) (si.count) #define SI_PTR(si) (si.cp) #define SI_SETLEN(si, len) (si.count = (UNS32)(len)) #define SI_SETPTR(si, ptr) (si.cp = (char *)(ptr)) /* ** Init a STRINGINFO from a pointer to NULL-terminated string */ #define SI_PSZ(si, psz) \ {si.cp = psz; si.count = (FICL_COUNT)strlen(psz);} /* ** Init a STRINGINFO from a pointer to FICL_STRING */ #define SI_PFS(si, pfs) \ {si.cp = pfs->text; si.count = pfs->count;} /* ** Ficl uses a this little structure to hold the address of ** the block of text it's working on and an index to the next ** unconsumed character in the string. Traditionally, this is ** done by a Text Input Buffer, so I've called this struct TIB. ** ** Since this structure also holds the size of the input buffer, ** and since evaluate requires that, let's put the size here. ** The size is stored as an end-pointer because that is what the ** null-terminated string aware functions find most easy to deal ** with. ** Notice, though, that nobody really uses this except evaluate, ** so it might just be moved to FICL_VM instead. (sobral) */ typedef struct { INT32 index; char *end; char *cp; } TIB; /* ** Stacks get heavy use in Ficl and Forth... ** Each virtual machine implements two of them: ** one holds parameters (data), and the other holds return ** addresses and control flow information for the virtual ** machine. (Note: C's automatic stack is implicitly used, ** but not modeled because it doesn't need to be...) ** Here's an abstract type for a stack */ typedef struct _ficlStack { FICL_UNS nCells; /* size of the stack */ CELL *pFrame; /* link reg for stack frame */ CELL *sp; /* stack pointer */ CELL base[1]; /* Bottom of the stack */ } FICL_STACK; /* ** Stack methods... many map closely to required Forth words. */ FICL_STACK *stackCreate(unsigned nCells); void stackDelete(FICL_STACK *pStack); int stackDepth (FICL_STACK *pStack); void stackDrop (FICL_STACK *pStack, int n); CELL stackFetch (FICL_STACK *pStack, int n); CELL stackGetTop(FICL_STACK *pStack); void stackLink (FICL_STACK *pStack, int nCells); void stackPick (FICL_STACK *pStack, int n); CELL stackPop (FICL_STACK *pStack); void *stackPopPtr (FICL_STACK *pStack); FICL_UNS stackPopUNS(FICL_STACK *pStack); FICL_INT stackPopINT(FICL_STACK *pStack); void stackPush (FICL_STACK *pStack, CELL c); void stackPushPtr (FICL_STACK *pStack, void *ptr); void stackPushUNS(FICL_STACK *pStack, FICL_UNS u); void stackPushINT(FICL_STACK *pStack, FICL_INT i); void stackReset (FICL_STACK *pStack); void stackRoll (FICL_STACK *pStack, int n); void stackSetTop(FICL_STACK *pStack, CELL c); void stackStore (FICL_STACK *pStack, int n, CELL c); void stackUnlink(FICL_STACK *pStack); /* ** The virtual machine (VM) contains the state for one interpreter. ** Defined operations include: ** Create & initialize ** Delete ** Execute a block of text ** Parse a word out of the input stream ** Call return, and branch ** Text output ** Throw an exception */ typedef struct ficl_word ** IPTYPE; /* the VM's instruction pointer */ /* ** Each VM has a placeholder for an output function - ** this makes it possible to have each VM do I/O ** through a different device. If you specify no ** OUTFUNC, it defaults to ficlTextOut. */ typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline); /* ** Each VM operates in one of two non-error states: interpreting ** or compiling. When interpreting, words are simply executed. ** When compiling, most words in the input stream have their ** addresses inserted into the word under construction. Some words ** (known as IMMEDIATE) are executed in the compile state, too. */ /* values of STATE */ #define INTERPRET 0 #define COMPILE 1 /* ** The pad is a small scratch area for text manipulation. ANS Forth ** requires it to hold at least 84 characters. */ #if !defined nPAD #define nPAD 256 #endif /* ** ANS Forth requires that a word's name contain {1..31} characters. */ #if !defined nFICLNAME #define nFICLNAME 31 #endif /* ** OK - now we can really define the VM... */ typedef struct vm { struct vm *link; /* Ficl keeps a VM list for simple teardown */ jmp_buf *pState; /* crude exception mechanism... */ OUTFUNC textOut; /* Output callback - see sysdep.c */ void * pExtend; /* vm extension pointer */ short fRestart; /* Set TRUE to restart runningWord */ IPTYPE ip; /* instruction pointer */ struct ficl_word *runningWord;/* address of currently running word (often just *(ip-1) ) */ UNS32 state; /* compiling or interpreting */ UNS32 base; /* number conversion base */ FICL_STACK *pStack; /* param stack */ FICL_STACK *rStack; /* return stack */ CELL sourceID; /* -1 if string, 0 if normal input */ TIB tib; /* address of incoming text string */ #if FICL_WANT_USER CELL user[FICL_USER_CELLS]; #endif char pad[nPAD]; /* the scratch area (see above) */ } FICL_VM; /* ** A FICL_CODE points to a function that gets called to help execute ** a word in the dictionary. It always gets passed a pointer to the ** running virtual machine, and from there it can get the address ** of the parameter area of the word it's supposed to operate on. ** For precompiled words, the code is all there is. For user defined ** words, the code assumes that the word's parameter area is a list ** of pointers to the code fields of other words to execute, and ** may also contain inline data. The first parameter is always ** a pointer to a code field. */ typedef void (*FICL_CODE)(FICL_VM *pVm); #if 0 #define VM_ASSERT(pVM) assert((*(pVM->ip - 1)) == pVM->runningWord) #else #define VM_ASSERT(pVM) #endif /* ** Ficl models memory as a contiguous space divided into ** words in a linked list called the dictionary. ** A FICL_WORD starts each entry in the list. ** Version 1.02: space for the name characters is allotted from ** the dictionary ahead of the word struct - this saves about half ** the storage on average with very little runtime cost. */ typedef struct ficl_word { struct ficl_word *link; /* Previous word in the dictionary */ UNS16 hash; UNS8 flags; /* Immediate, Smudge, Compile-only */ FICL_COUNT nName; /* Number of chars in word name */ char *name; /* First nFICLNAME chars of word name */ FICL_CODE code; /* Native code to execute the word */ CELL param[1]; /* First data cell of the word */ } FICL_WORD; /* ** Worst-case size of a word header: nFICLNAME chars in name */ #define CELLS_PER_WORD \ ( (sizeof (FICL_WORD) + nFICLNAME + sizeof (CELL)) \ / (sizeof (CELL)) ) int wordIsImmediate(FICL_WORD *pFW); int wordIsCompileOnly(FICL_WORD *pFW); /* flag values for word header */ #define FW_IMMEDIATE 1 /* execute me even if compiling */ #define FW_COMPILE 2 /* error if executed when not compiling */ #define FW_SMUDGE 4 /* definition in progress - hide me */ #define FW_CLASS 8 /* Word defines a class */ #define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE) #define FW_DEFAULT 0 /* ** Exit codes for vmThrow */ #define VM_INNEREXIT -256 /* tell ficlExecXT to exit inner loop */ #define VM_OUTOFTEXT -257 /* hungry - normal exit */ #define VM_RESTART -258 /* word needs more text to succeed - re-run it */ #define VM_USEREXIT -259 /* user wants to quit */ #define VM_ERREXIT -260 /* interp found an error */ #define VM_ABORT -1 /* like errexit -- abort */ #define VM_ABORTQ -2 /* like errexit -- abort" */ #define VM_QUIT -56 /* like errexit, but leave pStack & base alone */ void vmBranchRelative(FICL_VM *pVM, int offset); FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack); void vmDelete (FICL_VM *pVM); void vmExecute(FICL_VM *pVM, FICL_WORD *pWord); char * vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter); STRINGINFO vmGetWord(FICL_VM *pVM); STRINGINFO vmGetWord0(FICL_VM *pVM); int vmGetWordToPad(FICL_VM *pVM); STRINGINFO vmParseString(FICL_VM *pVM, char delimiter); +STRINGINFO vmParseStringEx(FICL_VM *pVM, char delimiter, char fSkipLeading); +CELL vmPop(FICL_VM *pVM); +void vmPush(FICL_VM *pVM, CELL c); void vmPopIP (FICL_VM *pVM); void vmPushIP (FICL_VM *pVM, IPTYPE newIP); void vmQuit (FICL_VM *pVM); void vmReset (FICL_VM *pVM); void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut); +#if FICL_WANT_DEBUGGER +void vmStep(FICL_VM *pVM); +#endif void vmTextOut(FICL_VM *pVM, char *text, int fNewline); void vmThrow (FICL_VM *pVM, int except); void vmThrowErr(FICL_VM *pVM, char *fmt, ...); #define vmGetRunningWord(pVM) ((pVM)->runningWord) /* ** The inner interpreter - coded as a macro (see note for ** INLINE_INNER_LOOP in sysdep.h for complaints about VC++ 5 */ -#define M_INNER_LOOP(pVM) \ - for (;;) \ - { \ +#define M_VM_STEP(pVM) \ FICL_WORD *tempFW = *(pVM)->ip++; \ (pVM)->runningWord = tempFW; \ tempFW->code(pVM); \ - } +#define M_INNER_LOOP(pVM) \ + for (;;) { M_VM_STEP(pVM) } + #if INLINE_INNER_LOOP != 0 #define vmInnerLoop(pVM) M_INNER_LOOP(pVM) #else void vmInnerLoop(FICL_VM *pVM); #endif /* ** vmCheckStack needs a vm pointer because it might have to say ** something if it finds a problem. Parms popCells and pushCells ** correspond to the number of parameters on the left and right of ** a word's stack effect comment. */ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells); /* ** TIB access routines... ** ANS forth seems to require the input buffer to be represented ** as a pointer to the start of the buffer, and an index to the ** next character to read. ** PushTib points the VM to a new input string and optionally ** returns a copy of the current state ** PopTib restores the TIB state given a saved TIB from PushTib ** GetInBuf returns a pointer to the next unused char of the TIB */ void vmPushTib(FICL_VM *pVM, char *text, INT32 nChars, TIB *pSaveTib); void vmPopTib(FICL_VM *pVM, TIB *pTib); #define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index) #define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp) #define vmGetInBufEnd(pVM) ((pVM)->tib.end) #define vmSetTibIndex(pVM, i) (pVM)->tib.index = i #define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp /* ** Generally useful string manipulators omitted by ANSI C... ** ltoa complements strtol */ #if defined(_WIN32) && !FICL_MAIN /* #SHEESH ** Why do Microsoft Meatballs insist on contaminating ** my namespace with their string functions??? */ #pragma warning(disable: 4273) #endif int isPowerOfTwo(FICL_UNS u); char *ltoa( FICL_INT value, char *string, int radix ); char *ultoa(FICL_UNS value, char *string, int radix ); char digit_to_char(int value); char *strrev( char *string ); char *skipSpace(char *cp, char *end); char *caseFold(char *cp); int strincmp(char *cp1, char *cp2, FICL_COUNT count); #if defined(_WIN32) && !FICL_MAIN #pragma warning(default: 4273) #endif /* ** Ficl hash table - variable size. ** assert(size > 0) ** If size is 1, the table degenerates into a linked list. ** A WORDLIST (see the search order word set in DPANS) is ** just a pointer to a FICL_HASH in this implementation. */ #if !defined HASHSIZE /* Default size of hash table. For most uniform */ #define HASHSIZE 127 /* performance, use a prime number! */ #endif typedef struct ficl_hash { struct ficl_hash *link; /* eventual inheritance support */ unsigned size; FICL_WORD *table[1]; } FICL_HASH; void hashForget(FICL_HASH *pHash, void *where); UNS16 hashHashCode(STRINGINFO si); void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW); FICL_WORD *hashLookup(struct ficl_hash *pHash, STRINGINFO si, UNS16 hashCode); void hashReset(FICL_HASH *pHash); /* ** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's ** memory model. Description of fields: ** ** here -- points to the next free byte in the dictionary. This ** pointer is forced to be CELL-aligned before a definition is added. ** Do not assume any specific alignment otherwise - Use dictAlign(). ** ** smudge -- pointer to word currently being defined (or last defined word) ** If the definition completes successfully, the word will be ** linked into the hash table. If unsuccessful, dictUnsmudge ** uses this pointer to restore the previous state of the dictionary. ** Smudge prevents unintentional recursion as a side-effect: the ** dictionary search algo examines only completed definitions, so a ** word cannot invoke itself by name. See the ficl word "recurse". ** NOTE: smudge always points to the last word defined. IMMEDIATE ** makes use of this fact. Smudge is initially NULL. ** ** pForthWords -- pointer to the default wordlist (FICL_HASH). ** This is the initial compilation list, and contains all ** ficl's precompiled words. ** ** pCompile -- compilation wordlist - initially equal to pForthWords ** pSearch -- array of pointers to wordlists. Managed as a stack. ** Highest index is the first list in the search order. ** nLists -- number of lists in pSearch. nLists-1 is the highest ** filled slot in pSearch, and points to the first wordlist ** in the search order ** size -- number of cells in the dictionary (total) ** dict -- start of data area. Must be at the end of the struct. */ typedef struct ficl_dict { CELL *here; FICL_WORD *smudge; FICL_HASH *pForthWords; FICL_HASH *pCompile; FICL_HASH *pSearch[FICL_DEFAULT_VOCS]; int nLists; unsigned size; /* Number of cells in dict (total)*/ CELL *dict; /* Base of dictionary memory */ } FICL_DICT; void *alignPtr(void *ptr); void dictAbortDefinition(FICL_DICT *pDict); void dictAlign(FICL_DICT *pDict); int dictAllot(FICL_DICT *pDict, int n); int dictAllotCells(FICL_DICT *pDict, int nCells); void dictAppendCell(FICL_DICT *pDict, CELL c); void dictAppendChar(FICL_DICT *pDict, char c); FICL_WORD *dictAppendWord(FICL_DICT *pDict, char *name, FICL_CODE pCode, UNS8 flags); FICL_WORD *dictAppendWord2(FICL_DICT *pDict, STRINGINFO si, FICL_CODE pCode, UNS8 flags); void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u); int dictCellsAvail(FICL_DICT *pDict); int dictCellsUsed (FICL_DICT *pDict); void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells); FICL_DICT *dictCreate(unsigned nCELLS); FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash); void dictDelete(FICL_DICT *pDict); void dictEmpty(FICL_DICT *pDict, unsigned nHash); int dictIncludes(FICL_DICT *pDict, void *p); FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si); #if FICL_WANT_LOCALS FICL_WORD *dictLookupLoc(FICL_DICT *pDict, STRINGINFO si); #endif void dictResetSearchOrder(FICL_DICT *pDict); void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr); void dictSetImmediate(FICL_DICT *pDict); void dictUnsmudge(FICL_DICT *pDict); CELL *dictWhere(FICL_DICT *pDict); /* ** External interface to FICL... */ /* ** f i c l I n i t S y s t e m ** Binds a global dictionary to the interpreter system and initializes ** the dict to contain the ANSI CORE wordset. ** You specify the address and size of the allocated area. ** After that, ficl manages it. ** First step is to set up the static pointers to the area. ** Then write the "precompiled" portion of the dictionary in. ** The dictionary needs to be at least large enough to hold the ** precompiled part. Try 1K cells minimum. Use "words" to find ** out how much of the dictionary is used at any time. */ void ficlInitSystem(int nDictCells); /* ** f i c l T e r m S y s t e m ** Deletes the system dictionary and all virtual machines that ** were created with ficlNewVM (see below). Call this function to ** reclaim all memory used by the dictionary and VMs. */ void ficlTermSystem(void); /* ** f i c l E x e c ** Evaluates a block of input text in the context of the ** specified interpreter. Emits any requested output to the ** interpreter's output function. If the input string is NULL ** terminated, you can pass -1 as nChars rather than count it. ** Execution returns when the text block has been executed, ** or an error occurs. ** Returns one of the VM_XXXX codes defined in ficl.h: ** VM_OUTOFTEXT is the normal exit condition ** VM_ERREXIT means that the interp encountered a syntax error ** and the vm has been reset to recover (some or all ** of the text block got ignored ** VM_USEREXIT means that the user executed the "bye" command ** to shut down the interpreter. This would be a good ** time to delete the vm, etc -- or you can ignore this ** signal. ** VM_ABORT and VM_ABORTQ are generated by 'abort' and 'abort"' ** commands. ** Preconditions: successful execution of ficlInitSystem, ** Successful creation and init of the VM by ficlNewVM (or equiv) */ int ficlExec (FICL_VM *pVM, char *pText); int ficlExecC(FICL_VM *pVM, char *pText, INT32 nChars); int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord); /* ** ficlExecFD(FICL_VM *pVM, int fd); * Evaluates text from file passed in via fd. * Execution returns when all of file has been executed or an * error occurs. */ int ficlExecFD(FICL_VM *pVM, int fd); /* ** Create a new VM from the heap, and link it into the system VM list. ** Initializes the VM and binds default sized stacks to it. Returns the ** address of the VM, or NULL if an error occurs. ** Precondition: successful execution of ficlInitSystem */ FICL_VM *ficlNewVM(void); + +/* +** Force deletion of a VM. You do not need to do this +** unless you're creating and discarding a lot of VMs. +** For systems that use a constant pool of VMs for the life +** of the system, ficltermSystem takes care of VM cleanup +** automatically. +*/ +void ficlFreeVM(FICL_VM *pVM); + /* ** Set the stack sizes (return and parameter) to be used for all ** subsequently created VMs. Returns actual stack size to be used. */ int ficlSetStackSize(int nStackCells); /* ** Returns the address of the most recently defined word in the system ** dictionary with the given name, or NULL if no match. ** Precondition: successful execution of ficlInitSystem */ FICL_WORD *ficlLookup(char *name); /* ** f i c l G e t D i c t ** Utility function - returns the address of the system dictionary. ** Precondition: successful execution of ficlInitSystem */ FICL_DICT *ficlGetDict(void); FICL_DICT *ficlGetEnv(void); void ficlSetEnv(char *name, UNS32 value); void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo); #if FICL_WANT_LOCALS FICL_DICT *ficlGetLoc(void); #endif /* ** f i c l B u i l d ** Builds a word into the system default dictionary in a thread-safe way. ** Preconditions: system must be initialized, and there must ** be enough space for the new word's header! Operation is ** controlled by ficlLockDictionary, so any initialization ** required by your version of the function (if you "overrode" ** it) must be complete at this point. ** Parameters: ** name -- the name of the word to be built ** code -- code to execute when the word is invoked - must take a single param ** pointer to a FICL_VM ** flags -- 0 or more of FW_IMMEDIATE, FW_COMPILE, use bitwise OR! ** Most words can use FW_DEFAULT. ** nAllot - number of extra cells to allocate in the parameter area (usually zero) */ int ficlBuild(char *name, FICL_CODE code, char flags); /* ** f i c l C o m p i l e C o r e ** Builds the ANS CORE wordset into the dictionary - called by ** ficlInitSystem - no need to waste dict space by doing it again. */ void ficlCompileCore(FICL_DICT *dp); void ficlCompileSoftCore(FICL_VM *pVM); /* ** from words.c... */ void constantParen(FICL_VM *pVM); void twoConstParen(FICL_VM *pVM); /* ** Dictionary on-demand resizing */ extern unsigned int dictThreshold; extern unsigned int dictIncrease; /* ** So we can more easily debug... */ #ifdef FICL_TRACE extern int ficl_trace; #endif #if defined(__i386__) && !defined(TESTMAIN) extern void ficlOutb(FICL_VM *pVM); extern void ficlInb(FICL_VM *pVM); #endif #ifdef __cplusplus } #endif #endif /* __FICL_H__ */ Index: head/sys/boot/ficl/softwords/classes.fr =================================================================== --- head/sys/boot/ficl/softwords/classes.fr (revision 60958) +++ head/sys/boot/ficl/softwords/classes.fr (revision 60959) @@ -1,140 +1,152 @@ \ ** ficl/softwords/classes.fr \ ** F I C L 2 . 0 C L A S S E S \ john sadler 1 sep 98 \ Needs oop.fr +\ +\ $FreeBSD$ .( loading ficl utility classes ) cr also oop definitions \ REF subclass holds a pointer to an object. It's \ mainly for aggregation to help in making data structures. \ object subclass c-ref cell: .class cell: .instance : get ( inst class -- refinst refclass ) drop 2@ ; : set ( refinst refclass inst class -- ) drop 2! ; end-class object subclass c-byte char: .payload : get drop c@ ; : set drop c! ; end-class object subclass c-2byte 2 chars: .payload : get drop w@ ; : set drop w! ; end-class object subclass c-4byte cell: .payload : get drop @ ; : set drop ! ; end-class \ ** C - P T R \ Base class for pointers to scalars (not objects). \ Note: use c-ref to make references to objects. C-ptr \ subclasses refer to untyped quantities of various sizes. \ Derived classes must specify the size of the thing \ they point to, and supply get and set methods. \ All derived classes must define the @size method: \ @size ( inst class -- addr-units ) \ Returns the size in address units of the thing the pointer \ refers to. object subclass c-ptr c-4byte obj: .addr \ get the value of the pointer : get-ptr ( inst class -- addr ) c-ptr => .addr c-4byte => get ; \ set the pointer to address supplied : set-ptr ( addr inst class -- ) c-ptr => .addr c-4byte => set ; + + \ force the pointer to be null + : clr-ptr + 0 -rot c-ptr => .addr c-4byte => set + ; + + \ return flag indicating null-ness + : ?null ( inst class -- flag ) + c-ptr => get-ptr 0= + ; \ increment the pointer in place : inc-ptr ( inst class -- ) 2dup 2dup ( i c i c i c ) c-ptr => get-ptr -rot ( i c addr i c ) --> @size + -rot ( addr' i c ) c-ptr => set-ptr ; \ decrement the pointer in place : dec-ptr ( inst class -- ) 2dup 2dup ( i c i c i c ) c-ptr => get-ptr -rot ( i c addr i c ) --> @size - -rot ( addr' i c ) c-ptr => set-ptr ; \ index the pointer in place : index-ptr ( index inst class -- ) locals| class inst index | inst class c-ptr => get-ptr ( addr ) inst class --> @size index * + ( addr' ) inst class c-ptr => set-ptr ; end-class \ ** C - C E L L P T R \ Models a pointer to cell (a 32 bit scalar). c-ptr subclass c-cellPtr : @size 2drop 4 ; \ fetch and store through the pointer : get ( inst class -- cell ) c-ptr => get-ptr @ ; : set ( value inst class -- ) c-ptr => get-ptr ! ; end-class \ ** C - 2 B Y T E P T R \ Models a pointer to a 16 bit scalar c-ptr subclass c-2bytePtr : @size 2drop 2 ; \ fetch and store through the pointer : get ( inst class -- value ) c-ptr => get-ptr w@ ; : set ( value inst class -- ) c-ptr => get-ptr w! ; end-class \ ** C - B Y T E P T R \ Models a pointer to an 8 bit scalar c-ptr subclass c-bytePtr : @size 2drop 1 ; \ fetch and store through the pointer : get ( inst class -- value ) c-ptr => get-ptr c@ ; : set ( value inst class -- ) c-ptr => get-ptr c! ; end-class previous definitions Index: head/sys/boot/ficl/softwords/jhlocal.fr =================================================================== --- head/sys/boot/ficl/softwords/jhlocal.fr (revision 60958) +++ head/sys/boot/ficl/softwords/jhlocal.fr (revision 60959) @@ -1,77 +1,90 @@ \ #if FICL_WANT_LOCALS \ ** ficl/softwords/jhlocal.fr \ ** stack comment style local syntax... \ { a b c | cleared -- d e } \ variables before the "|" are initialized in reverse order \ from the stack. Those after the "|" are zero initialized. \ Anything between "--" and "}" is treated as comment \ Uses locals... \ locstate: 0 = looking for | or -- or }} \ 1 = found | \ 2 = found -- +\ 3 = found } +\ 4 = end of line +\ +\ $FreeBSD$ + hide 0 constant zero : ?-- ( c-addr u -- c-addr u flag ) 2dup s" --" compare 0= ; : ?} ( c-addr u -- c-addr u flag ) 2dup s" }" compare 0= ; : ?| ( c-addr u -- c-addr u flag ) 2dup s" |" compare 0= ; +\ examine name and push true if it's a 2local +\ (starts with '2'), false otherwise. +: ?2loc ( c-addr u -- c-addr n flag ) + over c@ [char] 2 = if true else false endif ; + : ?delim ( c-addr u -- state | c-addr u 0 ) - ?| if - 2drop 1 - else - ?-- if - 2drop 2 - else - ?} if 2drop 3 else 0 endif - endif - endif + ?| if 2drop 1 exit endif + ?-- if 2drop 2 exit endif + ?} if 2drop 3 exit endif + dup 0= + if 2drop 4 exit endif + 0 ; set-current : { 0 dup locals| locstate | \ stack locals until we hit a delimiter begin parse-word \ ( nLocals c-addr u ) ?delim dup to locstate 0= while rot 1+ \ ( c-addr u ... c-addr u nLocals ) repeat \ now unstack the locals - 0 do (local) loop \ ( ) + 0 do + ?2loc if (2local) else (local) endif + loop \ ( ) \ zero locals until -- or } locstate 1 = if begin parse-word ?delim dup to locstate 0= while - postpone zero (local) + ?2loc if + postpone zero postpone zero (2local) + else + postpone zero (local) + endif repeat endif 0 0 (local) \ toss words until } locstate 2 = if begin parse-word ?delim dup to locstate 0= while 2drop repeat endif locstate 3 <> abort" syntax error in { } local line" ; immediate compile-only previous \ #endif Index: head/sys/boot/ficl/softwords/oo.fr =================================================================== --- head/sys/boot/ficl/softwords/oo.fr (revision 60958) +++ head/sys/boot/ficl/softwords/oo.fr (revision 60959) @@ -1,464 +1,498 @@ \ ** ficl/softwords/oo.fr \ ** F I C L O - O E X T E N S I O N S \ ** john sadler aug 1998 +\ +\ $FreeBSD$ + .( loading ficl O-O extensions ) cr 7 ficl-vocabulary oop also oop definitions \ Design goals: \ 0. Traditional OOP: late binding by default for safety. \ Early binding if you ask for it. \ 1. Single inheritance \ 2. Object aggregation (has-a relationship) \ 3. Support objects in the dictionary and as proxies for \ existing structures (by reference): \ *** A ficl object can wrap a C struct *** \ 4. Separate name-spaces for methods - methods are \ only visible in the context of a class / object \ 5. Methods can be overridden, and subclasses can add methods. \ No limit on number of methods. \ General info: \ Classes are objects, too: all classes are instances of METACLASS \ All classes are derived (by convention) from OBJECT. This \ base class provides a default initializer and superclass \ access method \ A ficl object binds instance storage (payload) to a class. \ object ( -- instance class ) \ All objects push their payload address and class address when \ executed. All objects have this footprint: \ cell 0: first payload cell \ A ficl class consists of a parent class pointer, a wordlist \ ID for the methods of the class, and a size for the payload \ of objects created by the class. A class is an object. \ The NEW method creates and initializes an instance of a class. \ Classes have this footprint: \ cell 0: parent class address \ cell 1: wordlist ID \ cell 2: size of instance's payload \ Methods expect an object couple ( instance class ) \ on the stack. \ Overridden methods must maintain the same stack signature as \ their predecessors. Ficl has no way of enforcing this, though. user current-class 0 current-class ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** L A T E B I N D I N G \ Compile the method name, and code to find and \ execute it at run-time... \ parse-method compiles the method name so that it pushes \ the string base address and count at run-time. \ : parse-method \ name run: ( -- c-addr u ) parse-word postpone sliteral ; compile-only : lookup-method ( class c-addr u -- class xt ) 2dup local u local c-addr end-locals 2 pick cell+ @ ( -- class c-addr u wid ) search-wordlist ( -- class 0 | xt 1 | xt -1 ) 0= if c-addr u type ." not found in " body> >name type cr abort endif ; : exec-method ( instance class c-addr u -- ) lookup-method execute ; : find-method-xt \ name ( class -- class xt ) parse-word lookup-method ; \ Method lookup operator takes a class-addr and instance-addr \ and executes the method from the class's wordlist if \ interpreting. If compiling, bind late. \ : --> ( instance class -- ??? ) state @ 0= if find-method-xt execute else parse-method postpone exec-method endif ; immediate \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** E A R L Y B I N D I N G \ Early binding operator compiles code to execute a method \ given its class at compile time. Classes are immediate, \ so they leave their cell-pair on the stack when compiling. \ Example: \ : get-wid metaclass => .wid @ ; \ Usage \ my-class get-wid ( -- wid-of-my-class ) \ : => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method drop find-method-xt compile, drop ; immediate compile-only \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** I N S T A N C E V A R I A B L E S \ Instance variables (IV) are represented by words in the class's \ private wordlist. Each IV word contains the offset \ of the IV it represents, and runs code to add that offset \ to the base address of an instance when executed. \ The metaclass SUB method, defined below, leaves the address \ of the new class's offset field and its initial size on the \ stack for these words to update. When a class definition is \ complete, END-CLASS saves the final size in the class's size \ field, and restores the search order and compile wordlist to \ prior state. Note that these words are hidden in their own \ wordlist to prevent accidental use outside a SUB END-CLASS pair. \ wordlist dup constant instance-vars dup >search ficl-set-current : do-instance-var does> ( instance class addr[offset] -- addr[field] ) nip @ + ; : addr-units: ( offset size "name" -- offset' ) create over , + do-instance-var ; : chars: \ ( offset nCells "name" -- offset' ) Create n char member. chars addr-units: ; : char: \ ( offset nCells "name" -- offset' ) Create 1 char member. 1 chars: ; : cells: ( offset nCells "name" -- offset' ) cells >r aligned r> addr-units: ; : cell: ( offset nCells "name" -- offset' ) 1 cells: ; \ Aggregate an object into the class... \ Needs the class of the instance to create \ Example: object obj: m_obj \ : do-aggregate does> ( instance class pfa -- a-instance a-class ) 2@ ( inst class a-class a-offset ) 2swap drop ( a-class a-offset inst ) + swap ( a-inst a-class ) ; : obj: ( offset class meta "name" -- offset' ) locals| meta class offset | create offset , class , class meta --> get-size offset + do-aggregate ; \ Aggregate an array of objects into a class \ Usage example: \ 3 my-class array: my-array \ Makes an instance variable array of 3 instances of my-class \ named my-array. \ : array: ( offset n class meta "name" -- offset' ) locals| meta class nobjs offset | create offset , class , class meta --> get-size nobjs * offset + do-aggregate ; \ Aggregate a pointer to an object: REF is a member variable \ whose class is set at compile time. This is useful for wrapping \ data structures in C, where there is only a pointer and the type \ it refers to is known. If you want polymorphism, see c_ref \ in classes.fr. REF is only useful for pre-initialized structures, \ since there's no supported way to set one. : ref: ( offset class meta "name" -- offset' ) locals| meta class offset | create offset , class , offset cell+ does> ( inst class pfa -- ptr-inst ptr-class ) 2@ ( inst class ptr-class ptr-offset ) 2swap drop + @ swap ; \ END-CLASS terminates construction of a class by storing \ the size of its instance variables in the class's size field \ ( -- old-wid addr[size] 0 ) \ : end-class ( old-wid addr[size] size -- ) swap ! set-current search> drop \ pop struct builder wordlist ; set-current previous \ E N D I N S T A N C E V A R I A B L E S \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ D O - D O - I N S T A N C E \ Makes a class method that contains the code for an \ instance of the class. This word gets compiled into \ the wordlist of every class by the SUB method. \ PRECONDITION: current-class contains the class address +\ why use a state variable instead of the stack? +\ >> Stack state is not well-defined during compilation (there are +\ >> control structure match codes on the stack, of undefined size +\ >> easiest way around this is use of this thread-local variable \ : do-do-instance ( -- ) s" : .do-instance does> [ current-class @ ] literal ;" evaluate ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** M E T A C L A S S \ Every class is an instance of metaclass. This lets \ classes have methods that are different from those \ of their instances. \ Classes are IMMEDIATE to make early binding simpler \ See above... \ :noname wordlist - create immediate + create + immediate 0 , \ NULL parent class dup , \ wid 3 cells , \ instance size ficl-set-current does> dup ; execute metaclass metaclass drop current-class ! do-do-instance \ \ C L A S S M E T H O D S \ instance-vars >search create .super ( class metaclass -- parent-class ) 0 cells , do-instance-var create .wid ( class metaclass -- wid ) \ return wid of class 1 cells , do-instance-var create .size ( class metaclass -- size ) \ return class's payload size 2 cells , do-instance-var previous : get-size metaclass => .size @ ; : get-wid metaclass => .wid @ ; : get-super metaclass => .super @ ; \ create an uninitialized instance of a class, leaving \ the address of the new instance and its class \ : instance ( class metaclass "name" -- instance class ) locals| meta parent | create here parent --> .do-instance \ ( inst class ) parent meta metaclass => get-size allot \ allocate payload space ; \ create an uninitialized array : array ( n class metaclass "name" -- n instance class ) locals| meta parent nobj | create nobj here parent --> .do-instance \ ( nobj inst class ) parent meta metaclass => get-size nobj * allot \ allocate payload space ; \ create an initialized instance \ : new \ ( class metaclass "name" -- ) metaclass => instance --> init ; \ create an initialized array of instances : new-array ( n class metaclass "name" -- ) metaclass => array --> array-init ; +\ Create an anonymous initialized instance from the heap +: alloc \ ( class metaclass -- instance class ) + locals| meta class | + class meta metaclass => get-size allocate ( -- addr fail-flag ) + abort" allocate failed " ( -- addr ) + class 2dup --> init +; + +\ Create an anonymous array of initialized instances from the heap +: alloc-array \ ( n class metaclass -- instance class ) + locals| meta class nobj | + class meta metaclass => get-size + nobj * allocate ( -- addr fail-flag ) + abort" allocate failed " ( -- addr ) + nobj over class --> array-init + class +; + \ create a proxy object with initialized payload address given : ref ( instance-addr class metaclass "name" -- ) drop create , , does> 2@ ; \ create a subclass : sub ( class metaclass "name" -- old-wid addr[size] size ) wordlist locals| wid meta parent | parent meta metaclass => get-wid wid wid-set-super create immediate here current-class ! \ prep for do-do-instance parent , \ save parent class wid , \ save wid here parent meta --> get-size dup , ( addr[size] size ) metaclass => .do-instance wid ficl-set-current -rot do-do-instance instance-vars >search \ push struct builder wordlist ; \ OFFSET-OF returns the offset of an instance variable \ from the instance base address. If the next token is not \ the name of in instance variable method, you get garbage \ results -- there is no way at present to check for this error. : offset-of ( class metaclass "name" -- offset ) drop find-method-xt nip >body @ ; \ ID returns the string name cell-pair of its class : id ( class metaclass -- c-addr u ) drop body> >name ; \ list methods of the class : methods \ ( class meta -- ) locals| meta class | begin class body> >name type ." methods:" cr class meta --> get-wid >search words cr previous class meta metaclass => get-super dup to class 0= until cr ; \ list class's ancestors : pedigree ( class meta -- ) locals| meta class | begin class body> >name type space class meta metaclass => get-super dup to class 0= until cr ; \ decompile a method : see ( class meta -- ) metaclass => get-wid >search see previous ; set-current \ E N D M E T A C L A S S \ META is a nickname for the address of METACLASS... metaclass drop constant meta \ SUBCLASS is a nickname for a class's SUB method... \ Subclass compilation ends when you invoke end-class \ This method is late bound for safety... : subclass --> sub ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** O B J E C T \ Root of all classes :noname wordlist create immediate 0 , \ NULL parent class dup , \ wid 0 , \ instance size ficl-set-current does> meta ; execute object object drop current-class ! do-do-instance \ O B J E C T M E T H O D S \ Convert instance cell-pair to class cell-pair \ Useful for binding class methods from an instance : class ( instance class -- class metaclass ) nip meta ; \ default INIT method zero fills an instance : init ( instance class -- ) meta metaclass => get-size ( inst size ) erase ; \ Apply INIT to an array of NOBJ objects... \ : array-init ( nobj inst class -- ) 0 dup locals| &init &next class inst | \ \ bind methods outside the loop to save time \ class s" init" lookup-method to &init s" next" lookup-method to &next drop 0 ?do inst class 2dup &init execute &next execute drop to inst loop +; + +\ free storage allocated to a heap instance by alloc or alloc-array +\ NOTE: not protected against errors like FREEing something that's +\ really in the dictionary. +: free \ ( instance class -- ) + drop free + abort" free failed " ; \ Instance aliases for common class methods \ Upcast to parent class : super ( instance class -- instance parent-class ) meta metaclass => get-super ; : pedigree ( instance class -- ) object => class metaclass => pedigree ; : size ( instance class -- sizeof-instance ) object => class metaclass => get-size ; : methods ( instance class -- ) object => class metaclass => methods ; \ Array indexing methods... \ Usage examples: \ 10 object-array --> index \ obj --> next \ : index ( n instance class -- instance[n] class ) locals| class inst | inst class object => class metaclass => get-size * ( n*size ) inst + class ; : next ( instance[n] class -- instance[n+1] class ) locals| class inst | inst class object => class metaclass => get-size inst + class ; : prev ( instance[n] class -- instance[n-1] class ) locals| class inst | inst class object => class metaclass => get-size inst swap - class ; set-current \ E N D O B J E C T previous definitions Index: head/sys/boot/ficl/softwords/softcore.fr =================================================================== --- head/sys/boot/ficl/softwords/softcore.fr (revision 60958) +++ head/sys/boot/ficl/softwords/softcore.fr (revision 60959) @@ -1,131 +1,133 @@ \ ** ficl/softwords/softcore.fr \ ** FICL soft extensions \ ** John Sadler (john_sadler@alum.mit.edu) \ ** September, 1998 \ $FreeBSD$ \ ** Ficl USER variables \ ** See words.c for primitive def'n of USER \ #if FICL_WANT_USER variable nUser 0 nUser ! : user \ name ( -- ) nUser dup @ user 1 swap +! ; \ #endif \ ** ficl extras \ EMPTY cleans the parameter stack : empty ( xn..x1 -- ) depth 0 ?do drop loop ; \ CELL- undoes CELL+ : cell- ( addr -- addr ) [ 1 cells ] literal - ; : -rot ( a b c -- c a b ) 2 -roll ; \ ** CORE : abs ( x -- x ) dup 0< if negate endif ; decimal 32 constant bl : space ( -- ) bl emit ; : spaces ( n -- ) 0 ?do space loop ; : abort" postpone if postpone ." postpone cr -2 postpone literal postpone throw postpone endif ; immediate \ ** CORE EXT 0 constant false -1 constant true : <> = 0= ; : 0<> 0= 0= ; : compile, , ; : erase ( addr u -- ) 0 fill ; : nip ( y x -- x ) swap drop ; : tuck ( y x -- x y x) swap over ; : within ( test low high -- flag ) over - >r - r> u< ; \ ** LOCAL EXT word set \ #if FICL_WANT_LOCALS : locals| ( name...name | -- ) begin bl word count dup 0= abort" where's the delimiter??" over c@ [char] | - over 1- or while (local) repeat 2drop 0 0 (local) ; immediate : local ( name -- ) bl word count (local) ; immediate +: 2local ( name -- ) bl word count (2local) ; immediate + : end-locals ( -- ) 0 0 (local) ; immediate \ #endif \ ** TOOLS word set... : ? ( addr -- ) @ . ; : dump ( addr u -- ) 0 ?do dup c@ . 1+ i 7 and 7 = if cr endif loop drop ; \ ** SEARCH+EXT words and ficl helpers \ : wordlist ( -- ) 1 ficl-wordlist ; \ DO_VOCABULARY handles the DOES> part of a VOCABULARY \ When executed, new voc replaces top of search stack : do-vocabulary ( -- ) does> @ search> drop >search ; : vocabulary ( name -- ) wordlist create , do-vocabulary ; : ficl-vocabulary ( nBuckets name -- ) ficl-wordlist create , do-vocabulary ; \ ALSO dups the search stack... : also ( -- ) search> dup >search >search ; \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST : forth ( -- ) search> drop forth-wordlist >search ; \ ONLY sets the search order to a default state : only ( -- ) -1 set-order ; \ ORDER displays the compile wid and the search order list : order ( -- ) ." Search: " get-order 0 ?do x. loop cr ." Compile: " get-current x. cr ; \ PREVIOUS drops the search order stack : previous ( -- ) search> drop ; \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value : ficl-set-current ( wid -- old-wid ) get-current swap set-current ; wordlist constant hidden : hide hidden dup >search ficl-set-current ; \ ** E N D S O F T C O R E . F R Index: head/sys/boot/ficl/vm.c =================================================================== --- head/sys/boot/ficl/vm.c (revision 60958) +++ head/sys/boot/ficl/vm.c (revision 60959) @@ -1,626 +1,668 @@ /******************************************************************* ** v m . c ** Forth Inspired Command Language - virtual machine methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 ** *******************************************************************/ /* ** This file implements the virtual machine of FICL. Each virtual ** machine retains the state of an interpreter. A virtual machine ** owns a pair of stacks for parameters and return addresses, as ** well as a pile of state variables and the two dedicated registers ** of the interp. */ /* $FreeBSD$ */ #ifdef TESTMAIN #include #include #include #else #include #endif #include #include #include "ficl.h" static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; /************************************************************************** v m B r a n c h R e l a t i v e ** **************************************************************************/ void vmBranchRelative(FICL_VM *pVM, int offset) { pVM->ip += offset; return; } /************************************************************************** v m C r e a t e ** **************************************************************************/ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) { if (pVM == NULL) { pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM)); assert (pVM); memset(pVM, 0, sizeof (FICL_VM)); } if (pVM->pStack) stackDelete(pVM->pStack); pVM->pStack = stackCreate(nPStack); if (pVM->rStack) stackDelete(pVM->rStack); pVM->rStack = stackCreate(nRStack); pVM->textOut = ficlTextOut; vmReset(pVM); return pVM; } /************************************************************************** v m D e l e t e ** **************************************************************************/ void vmDelete (FICL_VM *pVM) { if (pVM) { ficlFree(pVM->pStack); ficlFree(pVM->rStack); ficlFree(pVM); } return; } /************************************************************************** v m E x e c u t e ** Sets up the specified word to be run by the inner interpreter. ** Executes the word's code part immediately, but in the case of ** colon definition, the definition itself needs the inner interp ** to complete. This does not happen until control reaches ficlExec **************************************************************************/ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) { pVM->runningWord = pWord; pWord->code(pVM); return; } /************************************************************************** v m I n n e r L o o p ** the mysterious inner interpreter... ** This loop is the address interpreter that makes colon definitions ** work. Upon entry, it assumes that the IP points to an entry in ** a definition (the body of a colon word). It runs one word at a time ** until something does vmThrow. The catcher for this is expected to exist ** in the calling code. ** vmThrow gets you out of this loop with a longjmp() ** Visual C++ 5 chokes on this loop in Release mode. Aargh. **************************************************************************/ #if INLINE_INNER_LOOP == 0 void vmInnerLoop(FICL_VM *pVM) { M_INNER_LOOP(pVM); } #endif + /************************************************************************** v m G e t S t r i n g ** Parses a string out of the VM input buffer and copies up to the first ** FICL_STRING_MAX characters to the supplied destination buffer, a ** FICL_STRING. The destination string is NULL terminated. ** ** Returns the address of the first unused character in the dest buffer. **************************************************************************/ char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter) { - STRINGINFO si = vmParseString(pVM, delimiter); + STRINGINFO si = vmParseStringEx(pVM, delimiter, 0); if (SI_COUNT(si) > FICL_STRING_MAX) { SI_SETLEN(si, FICL_STRING_MAX); } strncpy(spDest->text, SI_PTR(si), SI_COUNT(si)); spDest->text[SI_COUNT(si)] = '\0'; spDest->count = (FICL_COUNT)SI_COUNT(si); return spDest->text + SI_COUNT(si) + 1; } /************************************************************************** v m G e t W o r d ** vmGetWord calls vmGetWord0 repeatedly until it gets a string with ** non-zero length. **************************************************************************/ STRINGINFO vmGetWord(FICL_VM *pVM) { STRINGINFO si = vmGetWord0(pVM); if (SI_COUNT(si) == 0) { vmThrow(pVM, VM_RESTART); } return si; } /************************************************************************** v m G e t W o r d 0 ** Skip leading whitespace and parse a space delimited word from the tib. ** Returns the start address and length of the word. Updates the tib ** to reflect characters consumed, including the trailing delimiter. ** If there's nothing of interest in the tib, returns zero. This function ** does not use vmParseString because it uses isspace() rather than a ** single delimiter character. **************************************************************************/ STRINGINFO vmGetWord0(FICL_VM *pVM) { char *pSrc = vmGetInBuf(pVM); char *pEnd = vmGetInBufEnd(pVM); STRINGINFO si; UNS32 count = 0; char ch; pSrc = skipSpace(pSrc, pEnd); SI_SETPTR(si, pSrc); for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc) { count++; } SI_SETLEN(si, count); if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); return si; } /************************************************************************** v m G e t W o r d T o P a d ** Does vmGetWord0 and copies the result to the pad as a NULL terminated ** string. Returns the length of the string. If the string is too long ** to fit in the pad, it is truncated. **************************************************************************/ int vmGetWordToPad(FICL_VM *pVM) { STRINGINFO si; char *cp = (char *)pVM->pad; si = vmGetWord0(pVM); if (SI_COUNT(si) > nPAD) SI_SETLEN(si, nPAD); strncpy(cp, SI_PTR(si), SI_COUNT(si)); cp[SI_COUNT(si)] = '\0'; return (int)(SI_COUNT(si)); } /************************************************************************** v m P a r s e S t r i n g ** Parses a string out of the input buffer using the delimiter ** specified. Skips leading delimiters, marks the start of the string, ** and counts characters to the next delimiter it encounters. It then ** updates the vm input buffer to consume all these chars, including the ** trailing delimiter. ** Returns the address and length of the parsed string, not including the ** trailing delimiter. **************************************************************************/ STRINGINFO vmParseString(FICL_VM *pVM, char delim) +{ + return vmParseStringEx(pVM, delim, 1); +} + +STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) { STRINGINFO si; char *pSrc = vmGetInBuf(pVM); char *pEnd = vmGetInBufEnd(pVM); char ch; - while ((pSrc != pEnd) && (*pSrc == delim)) /* skip lead delimiters */ - pSrc++; + if (fSkipLeading) + { /* skip lead delimiters */ + while ((pSrc != pEnd) && (*pSrc == delim)) + pSrc++; + } SI_SETPTR(si, pSrc); /* mark start of text */ for (ch = *pSrc; (pSrc != pEnd) && (ch != delim) && (ch != '\r') && (ch != '\n'); ch = *++pSrc) { ; /* find next delimiter or end of line */ } /* set length of result */ SI_SETLEN(si, pSrc - SI_PTR(si)); if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); return si; } /************************************************************************** + v m P o p +** +**************************************************************************/ +CELL vmPop(FICL_VM *pVM) +{ + return stackPop(pVM->pStack); +} + + +/************************************************************************** + v m P u s h +** +**************************************************************************/ +void vmPush(FICL_VM *pVM, CELL c) +{ + stackPush(pVM->pStack, c); + return; +} + + +/************************************************************************** v m P o p I P ** **************************************************************************/ void vmPopIP(FICL_VM *pVM) { pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack)); return; } /************************************************************************** v m P u s h I P ** **************************************************************************/ void vmPushIP(FICL_VM *pVM, IPTYPE newIP) { stackPushPtr(pVM->rStack, (void *)pVM->ip); pVM->ip = newIP; return; } /************************************************************************** v m P u s h T i b ** Binds the specified input string to the VM and clears >IN (the index) **************************************************************************/ void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib) { if (pSaveTib) { *pSaveTib = pVM->tib; } pVM->tib.cp = text; pVM->tib.end = text + nChars; pVM->tib.index = 0; } void vmPopTib(FICL_VM *pVM, TIB *pTib) { if (pTib) { pVM->tib = *pTib; } return; } /************************************************************************** v m Q u i t ** **************************************************************************/ void vmQuit(FICL_VM *pVM) { static FICL_WORD *pInterp = NULL; if (!pInterp) pInterp = ficlLookup("interpret"); assert(pInterp); stackReset(pVM->rStack); pVM->fRestart = 0; pVM->ip = &pInterp; pVM->runningWord = pInterp; pVM->state = INTERPRET; pVM->tib.cp = NULL; pVM->tib.end = NULL; pVM->tib.index = 0; pVM->pad[0] = '\0'; pVM->sourceID.i = 0; return; } /************************************************************************** v m R e s e t ** **************************************************************************/ void vmReset(FICL_VM *pVM) { vmQuit(pVM); stackReset(pVM->pStack); pVM->base = 10; return; } /************************************************************************** v m S e t T e x t O u t ** Binds the specified output callback to the vm. If you pass NULL, ** binds the default output function (ficlTextOut) **************************************************************************/ void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut) { if (textOut) pVM->textOut = textOut; else pVM->textOut = ficlTextOut; return; } + + +/************************************************************************** + v m S t e p +** Single step the vm - equivalent to "step into" - used for debugging +**************************************************************************/ +#if FICL_WANT_DEBUGGER +void vmStep(FICL_VM *pVM) +{ + M_VM_STEP(pVM); +} +#endif /************************************************************************** v m T e x t O u t ** Feeds text to the vm's output callback **************************************************************************/ void vmTextOut(FICL_VM *pVM, char *text, int fNewline) { assert(pVM); assert(pVM->textOut); (pVM->textOut)(pVM, text, fNewline); return; } /************************************************************************** v m T h r o w ** **************************************************************************/ void vmThrow(FICL_VM *pVM, int except) { if (pVM->pState) longjmp(*(pVM->pState), except); } void vmThrowErr(FICL_VM *pVM, char *fmt, ...) { va_list va; va_start(va, fmt); vsprintf(pVM->pad, fmt, va); vmTextOut(pVM, pVM->pad, 1); va_end(va); longjmp(*(pVM->pState), VM_ERREXIT); } /************************************************************************** w o r d I s I m m e d i a t e ** **************************************************************************/ int wordIsImmediate(FICL_WORD *pFW) { return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE)); } /************************************************************************** w o r d I s C o m p i l e O n l y ** **************************************************************************/ int wordIsCompileOnly(FICL_WORD *pFW) { return ((pFW != NULL) && (pFW->flags & FW_COMPILE)); } /************************************************************************** s t r r e v ** **************************************************************************/ char *strrev( char *string ) { /* reverse a string in-place */ int i = strlen(string); char *p1 = string; /* first char of string */ char *p2 = string + i - 1; /* last non-NULL char of string */ char c; if (i > 1) { while (p1 < p2) { c = *p2; *p2 = *p1; *p1 = c; p1++; p2--; } } return string; } /************************************************************************** d i g i t _ t o _ c h a r ** **************************************************************************/ char digit_to_char(int value) { return digits[value]; } /************************************************************************** i s P o w e r O f T w o ** Tests whether supplied argument is an integer power of 2 (2**n) ** where 32 > n > 1, and returns n if so. Otherwise returns zero. **************************************************************************/ int isPowerOfTwo(FICL_UNS u) { int i = 1; FICL_UNS t = 2; for (; ((t <= u) && (t != 0)); i++, t <<= 1) { if (u == t) return i; } return 0; } /************************************************************************** l t o a ** **************************************************************************/ char *ltoa( FICL_INT value, char *string, int radix ) { /* convert long to string, any base */ char *cp = string; int sign = ((radix == 10) && (value < 0)); int pwr; assert(radix > 1); assert(radix < 37); assert(string); pwr = isPowerOfTwo((FICL_UNS)radix); if (sign) value = -value; if (value == 0) *cp++ = '0'; else if (pwr != 0) { FICL_UNS v = (FICL_UNS) value; FICL_UNS mask = (FICL_UNS) ~(-1 << pwr); while (v) { *cp++ = digits[v & mask]; v >>= pwr; } } else { UNSQR result; DPUNS v; v.hi = 0; v.lo = (FICL_UNS)value; while (v.lo) { result = ficlLongDiv(v, (FICL_UNS)radix); *cp++ = digits[result.rem]; v.lo = result.quot; } } if (sign) *cp++ = '-'; *cp++ = '\0'; return strrev(string); } /************************************************************************** u l t o a ** **************************************************************************/ char *ultoa(FICL_UNS value, char *string, int radix ) { /* convert long to string, any base */ char *cp = string; DPUNS ud; UNSQR result; assert(radix > 1); assert(radix < 37); assert(string); if (value == 0) *cp++ = '0'; else { ud.hi = 0; ud.lo = value; result.quot = value; while (ud.lo) { result = ficlLongDiv(ud, (UNS32)radix); ud.lo = result.quot; *cp++ = digits[result.rem]; } } *cp++ = '\0'; return strrev(string); } /************************************************************************** c a s e F o l d ** Case folds a NULL terminated string in place. All characters ** get converted to lower case. **************************************************************************/ char *caseFold(char *cp) { char *oldCp = cp; while (*cp) { if (isupper(*cp)) *cp = (char)tolower(*cp); cp++; } return oldCp; } /************************************************************************** s t r i n c m p ** **************************************************************************/ int strincmp(char *cp1, char *cp2, FICL_COUNT count) { int i = 0; char c1, c2; for (c1 = *cp1, c2 = *cp2; ((i == 0) && count && c1 && c2); c1 = *++cp1, c2 = *++cp2, count--) { i = tolower(c1) - tolower(c2); } return i; } /************************************************************************** s k i p S p a c e ** Given a string pointer, returns a pointer to the first non-space ** char of the string, or to the NULL terminator if no such char found. ** If the pointer reaches "end" first, stop there. Pass NULL to ** suppress this behavior. **************************************************************************/ char *skipSpace(char *cp, char *end) { assert(cp); while ((cp != end) && isspace(*cp)) cp++; return cp; } Index: head/sys/boot/ficl/words.c =================================================================== --- head/sys/boot/ficl/words.c (revision 60958) +++ head/sys/boot/ficl/words.c (revision 60959) @@ -1,4863 +1,4977 @@ /******************************************************************* ** 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 ** *******************************************************************/ /* $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 void interpWord(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"; /* ** Pointers to various words in the dictionary ** -- initialized by ficlCompileCore, below -- ** for use by compiling words. Colon definitions ** in ficl are lists of pointers to words. A bit ** simple-minded... */ static FICL_WORD *pBranchParen = NULL; static FICL_WORD *pComma = NULL; static FICL_WORD *pDoParen = NULL; static FICL_WORD *pDoesParen = NULL; static FICL_WORD *pExitParen = NULL; static FICL_WORD *pIfParen = NULL; static FICL_WORD *pInterpret = NULL; static FICL_WORD *pLitParen = NULL; +static FICL_WORD *pTwoLitParen = NULL; static FICL_WORD *pLoopParen = NULL; static FICL_WORD *pPLoopParen = NULL; static FICL_WORD *pQDoParen = NULL; static FICL_WORD *pSemiParen = NULL; static FICL_WORD *pStore = NULL; static FICL_WORD *pStringLit = NULL; static FICL_WORD *pType = NULL; #if FICL_WANT_LOCALS static FICL_WORD *pGetLocalParen= NULL; +static FICL_WORD *pGet2LocalParen= NULL; static FICL_WORD *pGetLocal0 = NULL; static FICL_WORD *pGetLocal1 = NULL; static FICL_WORD *pToLocalParen = NULL; +static FICL_WORD *pTo2LocalParen = NULL; static FICL_WORD *pToLocal0 = NULL; static FICL_WORD *pToLocal1 = NULL; static FICL_WORD *pLinkParen = NULL; static FICL_WORD *pUnLinkParen = NULL; static int nLocals = 0; +static CELL *pMarkLocals = NULL; + +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) { stackPushPtr(pVM->pStack, dp->here); stackPushPtr(pVM->pStack, tag); return; } static void markControlTag(FICL_VM *pVM, char *tag) { stackPushPtr(pVM->pStack, tag); return; } static void matchControlTag(FICL_VM *pVM, char *tag) { char *cp = (char *)stackPopPtr(pVM->pStack); if ( 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) { long offset; CELL *patchAddr; matchControlTag(pVM, tag); 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) { long offset; CELL *patchAddr; matchControlTag(pVM, tag); 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; cp = stackPopPtr(pVM->pStack); if (strcmp(cp, tag)) { vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); vmTextOut(pVM, tag, 1); } patchAddr = (CELL *)stackPopPtr(pVM->pStack); *patchAddr = LVALUEtoCELL(dp->here); return; } /************************************************************************** i s 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. **************************************************************************/ static int isNumber(FICL_VM *pVM, STRINGINFO si) { FICL_INT accum = 0; char isNeg = FALSE; unsigned base = pVM->base; char *cp = SI_PTR(si); FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); unsigned ch; unsigned digit; if (*cp == '-') { cp++; count--; isNeg = TRUE; } else if ((cp[0] == '0') && (cp[1] == 'x')) { /* detect 0xNNNN format for hex numbers */ cp += 2; count -= 2; base = 16; } if (count == 0) return FALSE; while (count-- && ((ch = *cp++) != '\0')) { if (!(isdigit(ch)||isalpha(ch))) return FALSE; digit = ch - '0'; if (digit > 9) digit = tolower(ch) - 'a' + 10; if (digit >= base) return FALSE; accum = accum * base + digit; } if (isNeg) accum = -accum; stackPushINT(pVM->pStack, accum); return TRUE; } +static void ficlIsNum(FICL_VM *pVM) +{ + STRINGINFO si; + FICL_INT ret; + + SI_SETLEN(si, stackPopINT(pVM->pStack)); + SI_SETPTR(si, stackPopPtr(pVM->pStack)); + ret = isNumber(pVM, si) ? FICL_TRUE : FICL_FALSE; + stackPushINT(pVM->pStack, ret); + return; +} + /************************************************************************** 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, qr.rem); stackPushINT(pVM->pStack, 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; stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, qr.rem); stackPushINT(pVM->pStack, qr.quot); return; } /************************************************************************** b y e ** TOOLS ** Signal the system to shut down - this causes ficlExec to return ** VM_USEREXIT. The rest is up to you. **************************************************************************/ static void bye(FICL_VM *pVM) { vmThrow(pVM, VM_USEREXIT); 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 = ficlGetDict(); STRINGINFO si = vmGetWord(pVM); dictCheckThreshold(dp); pVM->state = COMPILE; markControlTag(pVM, colonTag); dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); #if FICL_WANT_LOCALS 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 = ficlGetDict(); assert(pSemiParen); matchControlTag(pVM, colonTag); #if FICL_WANT_LOCALS assert(pUnLinkParen); if (nLocals > 0) { FICL_DICT *pLoc = ficlGetLoc(); dictEmpty(pLoc, pLoc->pForthWords->size); dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); } nLocals = 0; #endif dictAppendCell(dp, LVALUEtoCELL(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 = ficlGetDict(); assert(pExitParen); IGNORE(pVM); #if FICL_WANT_LOCALS if (nLocals > 0) { dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); } #endif dictAppendCell(dp, LVALUEtoCELL(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 = ficlGetDict(); 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 = ficlGetDict(); 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 displayCellNoPad(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); 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; } /************************************************************************** d i s p l a y S t a c k ** Display the parameter stack (code for ".s") **************************************************************************/ static void displayStack(FICL_VM *pVM) { int d = stackDepth(pVM->pStack); int i; CELL *pCell; vmCheckStack(pVM, 0, 0); if (d == 0) vmTextOut(pVM, "(Stack Empty)", 1); else { pCell = pVM->pStack->sp; for (i = 0; i < d; i++) { vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1); } } } /************************************************************************** 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); stackPushINT(pVM->pStack, 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 = pVM->pad; 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) { - vmParseString(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 wFetch(FICL_VM *pVM) { UNS16 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pw = (UNS16 *)stackPopPtr(pVM->pStack); stackPushUNS(pVM->pStack, (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); stackPushUNS(pVM->pStack, (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); } /************************************************************************** i f C o I m ** IMMEDIATE ** Compiles code for a conditional branch into the dictionary ** and pushes the branch patch address on the stack for later ** patching by ELSE or THEN/ENDIF. **************************************************************************/ static void ifCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); markBranch(dp, pVM, origTag); dictAppendUNS(dp, 1); return; } /************************************************************************** i f P a r e n ** Runtime code to do "if" or "until": pop a flag from the stack, ** fall through if true, branch if false. Probably ought to be ** called (not?branch) since it does "branch if false". **************************************************************************/ -#ifdef FICL_TRACE -void ifParen(FICL_VM *pVM) -#else static void ifParen(FICL_VM *pVM) -#endif { 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, *(int*)(pVM->ip)); } return; } /************************************************************************** e l s e C o I m ** ** IMMEDIATE -- 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 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; int offset; FICL_DICT *dp = ficlGetDict(); assert(pBranchParen); /* (1) compile branch runtime */ dictAppendCell(dp, LVALUEtoCELL(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; } /************************************************************************** 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. **************************************************************************/ -#ifdef FICL_TRACE -void branchParen(FICL_VM *pVM) -#else static void branchParen(FICL_VM *pVM) -#endif { vmBranchRelative(pVM, *(int *)(pVM->ip)); return; } /************************************************************************** e n d i f C o I m ** **************************************************************************/ static void endifCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); resolveForwardBranch(dp, pVM, origTag); return; } /************************************************************************** + 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)); + stackPushUNS(pVM->pStack, 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 = vmGetWord0(pVM); assert(pVM); vmBranchRelative(pVM, -1); /* ** Get next word...if out of text, we're done. */ if (si.count == 0) + { vmThrow(pVM, VM_OUTOFTEXT); + } interpWord(pVM, si); + return; /* back to inner interpreter */ } /************************************************************************** ** 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). **************************************************************************/ static void interpWord(FICL_VM *pVM, STRINGINFO si) { FICL_DICT *dp = ficlGetDict(); FICL_WORD *tempFW; #if FICL_ROBUST dictCheck(dp, pVM, 0); vmCheckStack(pVM, 0, 0); #endif #if FICL_WANT_LOCALS if (nLocals > 0) { tempFW = dictLookupLoc(dp, 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); } else if (!isNumber(pVM, si)) { int i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); } } else /* (pVM->state == COMPILE) */ { if (tempFW != NULL) { if (wordIsImmediate(tempFW)) { vmExecute(pVM, tempFW); } else { dictAppendCell(dp, LVALUEtoCELL(tempFW)); } } else if (isNumber(pVM, si)) { literalIm(pVM); } else { int i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); } } 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". ** **************************************************************************/ -#ifdef FICL_TRACE -void literalParen(FICL_VM *pVM) -#else + static void literalParen(FICL_VM *pVM) -#endif { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 1); return; } +static void twoLitParen(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 2); +#endif + stackPushINT(pVM->pStack, *((FICL_INT *)(pVM->ip)+1)); + stackPushINT(pVM->pStack, *(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 = ficlGetDict(); assert(pLitParen); dictAppendCell(dp, LVALUEtoCELL(pLitParen)); dictAppendCell(dp, stackPop(pVM->pStack)); return; } +static void twoLiteralIm(FICL_VM *pVM) +{ + FICL_DICT *dp = ficlGetDict(); + assert(pTwoLitParen); + + dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen)); + dictAppendCell(dp, stackPop(pVM->pStack)); + dictAppendCell(dp, stackPop(pVM->pStack)); + + return; +} + /************************************************************************** l i s t W o r d s ** **************************************************************************/ #define nCOLWIDTH 8 static void listWords(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; FICL_WORD *wp; int nChars = 0; int len; int y = 0; unsigned i; int nWords = 0; char *cp; char *pPad = pVM->pad; for (i = 0; i < pHash->size; i++) { for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) { if (wp->nName == 0) /* ignore :noname defs */ continue; cp = wp->name; nChars += sprintf(pPad + nChars, "%s", cp); if (nChars > 70) { pPad[nChars] = '\0'; nChars = 0; y++; if(y>23) { y=0; vmTextOut(pVM, "--- Press Enter to continue ---",0); getchar(); vmTextOut(pVM,"\r",0); } vmTextOut(pVM, pPad, 1); } else { len = nCOLWIDTH - nChars % nCOLWIDTH; while (len-- > 0) pPad[nChars++] = ' '; } if (nChars > 70) { pPad[nChars] = '\0'; nChars = 0; y++; if(y>23) { y=0; vmTextOut(pVM, "--- Press Enter to continue ---",0); getchar(); vmTextOut(pVM,"\r",0); } vmTextOut(pVM, pPad, 1); } } } if (nChars > 0) { pPad[nChars] = '\0'; nChars = 0; vmTextOut(pVM, pPad, 1); } sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total", nWords, dp->here - dp->dict, dp->size); vmTextOut(pVM, pVM->pad, 1); return; } static void listEnv(FICL_VM *pVM) { FICL_DICT *dp = ficlGetEnv(); FICL_HASH *pHash = dp->pForthWords; FICL_WORD *wp; unsigned i; int nWords = 0; for (i = 0; i < pHash->size; i++) { for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) { vmTextOut(pVM, wp->name, 1); } } sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total", nWords, dp->here - dp->dict, dp->size); vmTextOut(pVM, pVM->pad, 1); 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i)); 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, 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); stackPushINT(pVM->pStack, ~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 = ficlGetDict(); assert(pDoParen); dictAppendCell(dp, LVALUEtoCELL(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; } -#ifdef FICL_TRACE -void doParen(FICL_VM *pVM) -#else + static void doParen(FICL_VM *pVM) -#endif { 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 = ficlGetDict(); assert(pQDoParen); dictAppendCell(dp, LVALUEtoCELL(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; } -#ifdef FICL_TRACE -void qDoParen(FICL_VM *pVM) -#else + static void qDoParen(FICL_VM *pVM) -#endif { 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 = ficlGetDict(); assert(pLoopParen); dictAppendCell(dp, LVALUEtoCELL(pLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; } static void plusLoopCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); assert(pPLoopParen); dictAppendCell(dp, LVALUEtoCELL(pPLoopParen)); resolveBackBranch(dp, pVM, doTag); resolveAbsBranch(dp, pVM, leaveTag); return; } -#ifdef FICL_TRACE -void loopParen(FICL_VM *pVM) -#else + static void loopParen(FICL_VM *pVM) -#endif { 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, *(int *)(pVM->ip)); } return; } -#ifdef FICL_TRACE -void plusLoopParen(FICL_VM *pVM) -#else + static void plusLoopParen(FICL_VM *pVM) -#endif { FICL_INT index = stackGetTop(pVM->rStack).i; FICL_INT limit = stackFetch(pVM->rStack, 1).i; FICL_INT increment = stackPop(pVM->pStack).i; int flag; 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, *(int *)(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) { stackPush(pVM->rStack, stackPop(pVM->pStack)); return; } static void fromRStack(FICL_VM *pVM) { stackPush(pVM->pStack, stackPop(pVM->rStack)); return; } static void fetchRStack(FICL_VM *pVM) { stackPush(pVM->pStack, stackGetTop(pVM->rStack)); return; } /************************************************************************** v a r i a b l e ** **************************************************************************/ static void variableParen(FICL_VM *pVM) { FICL_WORD *fw = pVM->runningWord; stackPushPtr(pVM->pStack, fw->param); return; } static void variable(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, variableParen, FW_DEFAULT); dictAllotCells(dp, 1); return; } /************************************************************************** b a s e & f r i e n d s ** **************************************************************************/ static void base(FICL_VM *pVM) { CELL *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 = ficlGetDict(); FICL_INT i = stackPopINT(pVM->pStack); #if FICL_ROBUST dictCheck(dp, pVM, i); #endif dictAllot(dp, i); return; } static void here(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); stackPushPtr(pVM->pStack, dp->here); return; } static void comma(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); CELL c = stackPop(pVM->pStack); dictAppendCell(dp, c); return; } static void cComma(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); char c = (char)stackPopINT(pVM->pStack); dictAppendChar(dp, c); return; } static void cells(FICL_VM *pVM) { FICL_INT i = stackPopINT(pVM->pStack); stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL)); return; } static void cellPlus(FICL_VM *pVM) { char *cp = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, 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. **************************************************************************/ static void tick(FICL_VM *pVM) { FICL_WORD *pFW = NULL; STRINGINFO si = vmGetWord(pVM); pFW = dictLookup(ficlGetDict(), si); if (!pFW) { int i = SI_COUNT(si); vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); } stackPushPtr(pVM->pStack, pFW); return; } static void bracketTickCoIm(FICL_VM *pVM) { tick(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 = ficlGetDict(); FICL_WORD *pFW; assert(pComma); tick(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(ficlGetDict()); return; } static void compileOnly(FICL_VM *pVM) { IGNORE(pVM); dictSetFlags(ficlGetDict(), FW_COMPILE, 0); 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. **************************************************************************/ -#ifdef FICL_TRACE -void stringLit(FICL_VM *pVM) -#else + static void stringLit(FICL_VM *pVM) -#endif { FICL_STRING *sp = (FICL_STRING *)(pVM->ip); FICL_COUNT count = sp->count; char *cp = sp->text; stackPushPtr(pVM->pStack, cp); stackPushUNS(pVM->pStack, count); cp += count + 1; cp = alignPtr(cp); pVM->ip = (IPTYPE)(void *)cp; return; } static void dotQuoteCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); dictAppendCell(dp, LVALUEtoCELL(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; - pSrc = skipSpace(pSrc, pEnd); - 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 = ficlGetDict(); char *cp, *cpDest; FICL_UNS u; u = stackPopUNS(pVM->pStack); cp = stackPopPtr(pVM->pStack); dictAppendCell(dp, LVALUEtoCELL(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) { stackPushPtr(pVM->pStack, &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 = pVM->runningWord->param; stackPushPtr(pVM->pStack, pCell+1); return; } static void create(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); STRINGINFO si = vmGetWord(pVM); dictAppendWord2(dp, si, createParen, FW_DEFAULT); dictAllotCells(dp, 1); return; } static void doDoes(FICL_VM *pVM) { CELL *pCell = pVM->runningWord->param; IPTYPE tempIP = (IPTYPE)((*pCell).p); stackPushPtr(pVM->pStack, pCell+1); vmPushIP(pVM, tempIP); return; } static void doesParen(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); dp->smudge->code = doDoes; dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); vmPopIP(pVM); return; } static void doesCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); #if FICL_WANT_LOCALS assert(pUnLinkParen); if (nLocals > 0) { FICL_DICT *pLoc = ficlGetLoc(); dictEmpty(pLoc, pLoc->pForthWords->size); dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); } nLocals = 0; #endif IGNORE(pVM); dictAppendCell(dp, LVALUEtoCELL(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 = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, pFW->param + 1); return; } /* ** from-body ficl ( a-addr -- xt ) ** Reverse effect of >body */ static void fromBody(FICL_VM *pVM) { char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD); stackPushPtr(pVM->pStack, 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 = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, pFW->name); stackPushUNS(pVM->pStack, pFW->nName); 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 = PTRtoSTRING pVM->pad; DPUNS u; UNS16 rem; 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 = PTRtoSTRING pVM->pad; sp->text[sp->count] = '\0'; strrev(sp->text); stackDrop(pVM->pStack, 2); stackPushPtr(pVM->pStack, sp->text); stackPushUNS(pVM->pStack, 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 = PTRtoSTRING pVM->pad; DPUNS u; UNS16 rem; 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 = PTRtoSTRING pVM->pad; int i = stackPopINT(pVM->pStack); 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 = PTRtoSTRING pVM->pad; int i = stackPopINT(pVM->pStack); 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 = stackPopUNS(pVM->pStack); char *cp = (char *)stackPopPtr(pVM->pStack); DPUNS accum; FICL_UNS base = pVM->base; FICL_UNS ch; FICL_UNS digit; 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); stackPushPtr (pVM->pStack, cp); stackPushUNS(pVM->pStack, 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_INT count; char *cp; char *pBuf = vmGetInBuf(pVM); char *pEnd = vmGetInBufEnd(pVM); FICL_INT 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); stackPushINT(pVM->pStack, 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 = ficlGetDict(); IGNORE(pVM); dictAlign(dp); return; } /************************************************************************** a l i g n e d ** **************************************************************************/ static void aligned(FICL_VM *pVM) { void *addr = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, 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 = ficlGetDict(); markBranch(dp, pVM, destTag); return; } static void untilCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); resolveBackBranch(dp, pVM, destTag); return; } static void whileCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); markBranch(dp, pVM, origTag); twoSwap(pVM); dictAppendUNS(dp, 1); return; } static void repeatCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); assert(pBranchParen); dictAppendCell(dp, LVALUEtoCELL(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 = ficlGetDict(); + + assert(pBranchParen); + dictAppendCell(dp, LVALUEtoCELL(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 = vmGetWord(pVM); stackPushUNS(pVM->pStack, (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 = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, 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 = stackPopINT(pVM->pStack); stackPushINT(pVM->pStack, 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 = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, sp->text); stackPushUNS(pVM->pStack, 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 = ficlGetEnv(); FICL_COUNT len = (FICL_COUNT)stackPopUNS(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); FICL_WORD *pFW; STRINGINFO si; &len; /* silence compiler warning... */ SI_PSZ(si, cp); pFW = dictLookup(envp, si); if (pFW != NULL) { vmExecute(pVM, pFW); stackPushINT(pVM->pStack, FICL_TRUE); } else { stackPushINT(pVM->pStack, 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 andinput buffer, set >IN to zero, and interpret. +** 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_INT count = stackPopINT(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); CELL id; int result; 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 ** Intrpreting: 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 = ficlGetDict(); if (pVM->state == INTERPRET) { FICL_STRING *sp = (FICL_STRING *) dp->here; vmGetString(pVM, sp, '\"'); stackPushPtr(pVM->pStack, sp->text); stackPushUNS(pVM->pStack, sp->count); } else /* COMPILE state */ { dictAppendCell(dp, LVALUEtoCELL(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 = (FICL_STRING *)pVM->pad; char delim = (char)stackPopINT(pVM->pStack); STRINGINFO si; - si = vmParseString(pVM, delim); + 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)); strcat(sp->text, " "); stackPushPtr(pVM->pStack, 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 = vmGetWord0(pVM); stackPushPtr(pVM->pStack, SI_PTR(si)); stackPushUNS(pVM->pStack, 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) { - char *pSrc = vmGetInBuf(pVM); - char *pEnd = vmGetInBufEnd(pVM); - char *cp; - FICL_UNS count; - char delim = (char)stackPopINT(pVM->pStack); + STRINGINFO si; + char delim = (char)stackPopINT(pVM->pStack); - cp = pSrc; /* mark start of text */ - - while ((pSrc != pEnd) && (*pSrc != delim)) - { - pSrc++; /* find next delimiter or end */ - } - - count = pSrc - cp; /* set length of result */ - - if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ - pSrc++; - - vmUpdateTib(pVM, pSrc); - stackPushPtr(pVM->pStack, cp); - stackPushUNS(pVM->pStack, count); + si = vmParseStringEx(pVM, delim, 0); + stackPushPtr(pVM->pStack, SI_PTR(si)); + stackPushUNS(pVM->pStack, 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 = (char)stackPopINT(pVM->pStack); FICL_UNS u = stackPopUNS(pVM->pStack); char *cp = (char *)stackPopPtr(pVM->pStack); 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 find(FICL_VM *pVM) { FICL_STRING *sp = stackPopPtr(pVM->pStack); FICL_WORD *pFW; STRINGINFO si; SI_PFS(si, sp); pFW = dictLookup(ficlGetDict(), si); if (pFW) { stackPushPtr(pVM->pStack, pFW); stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); } else { stackPushPtr(pVM->pStack, sp); stackPushUNS(pVM->pStack, 0); } return; } + /************************************************************************** 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; n1 = stackPopINT(pVM->pStack); d1 = i64Pop(pVM->pStack); qr = m64FlooredDivI(d1, n1); stackPushINT(pVM->pStack, qr.rem); stackPushINT(pVM->pStack, 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; n1 = stackPopINT(pVM->pStack); d1 = i64Pop(pVM->pStack); qr = m64SymmetricDivI(d1, n1); stackPushINT(pVM->pStack, qr.rem); stackPushINT(pVM->pStack, qr.quot); return; } static void ficlMod(FICL_VM *pVM) { DPINT d1; FICL_INT n1; INTQR qr; n1 = stackPopINT(pVM->pStack); d1.lo = stackPopINT(pVM->pStack); i64Extend(d1); qr = m64SymmetricDivI(d1, n1); stackPushINT(pVM->pStack, 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); stackPushUNS(pVM->pStack, qr.rem); stackPushUNS(pVM->pStack, 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 = stackPopUNS(pVM->pStack); FICL_UNS x1 = stackPopUNS(pVM->pStack); stackPushUNS(pVM->pStack, x1 << nBits); return; } static void rshift(FICL_VM *pVM) { FICL_UNS nBits = stackPopUNS(pVM->pStack); FICL_UNS x1 = stackPopUNS(pVM->pStack); stackPushUNS(pVM->pStack, 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 = stackPopINT(pVM->pStack); FICL_INT n1 = stackPopINT(pVM->pStack); DPINT d; d = m64MulI(n1, n2); i64Push(pVM->pStack, d); return; } static void umStar(FICL_VM *pVM) { FICL_UNS u2 = stackPopUNS(pVM->pStack); FICL_UNS u1 = stackPopUNS(pVM->pStack); DPUNS ud; ud = ficlLongMul(u1, u2); u64Push(pVM->pStack, ud); return; } /************************************************************************** m a x & m i n ** **************************************************************************/ static void ficlMax(FICL_VM *pVM) { FICL_INT n2 = stackPopINT(pVM->pStack); FICL_INT n1 = stackPopINT(pVM->pStack); stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2); return; } static void ficlMin(FICL_VM *pVM) { FICL_INT n2 = stackPopINT(pVM->pStack); FICL_INT n1 = stackPopINT(pVM->pStack); stackPushINT(pVM->pStack, (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 = stackPopUNS(pVM->pStack); char *addr2 = stackPopPtr(pVM->pStack); char *addr1 = stackPopPtr(pVM->pStack); 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 = ficlGetDict(); 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 = stackPopINT(pVM->pStack); /* sign extend to 64 bits.. */ stackPushINT(pVM->pStack, s); stackPushINT(pVM->pStack, (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) -{ int i; - +{ stackPushPtr(pVM->pStack, pVM->tib.cp); stackPushINT(pVM->pStack, 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) { stackPushPtr(pVM->pStack, &pVM->tib.index); return; } /************************************************************************** d e f i n i t i o n s ** SEARCH ( -- ) ** Make the compilation word list the same as the first word list in the ** search order. Specifies that the names of subsequent definitions will ** be placed in the compilation word list. Subsequent changes in the search ** order will not affect the compilation word list. **************************************************************************/ static void definitions(FICL_VM *pVM) { FICL_DICT *pDict = ficlGetDict(); assert(pDict); if (pDict->nLists < 1) { vmThrowErr(pVM, "DEFINITIONS error - empty search order"); } pDict->pCompile = pDict->pSearch[pDict->nLists-1]; return; } /************************************************************************** f o r t h - w o r d l i s t ** SEARCH ( -- wid ) ** Return wid, the identifier of the word list that includes all standard ** words provided by the implementation. This word list is initially the ** compilation word list and is part of the initial search order. **************************************************************************/ static void forthWordlist(FICL_VM *pVM) { FICL_HASH *pHash = ficlGetDict()->pForthWords; stackPushPtr(pVM->pStack, pHash); return; } /************************************************************************** g e t - c u r r e n t ** SEARCH ( -- wid ) ** Return wid, the identifier of the compilation word list. **************************************************************************/ static void getCurrent(FICL_VM *pVM) { ficlLockDictionary(TRUE); stackPushPtr(pVM->pStack, ficlGetDict()->pCompile); ficlLockDictionary(FALSE); return; } /************************************************************************** g e t - o r d e r ** SEARCH ( -- widn ... wid1 n ) ** Returns the number of word lists n in the search order and the word list ** identifiers widn ... wid1 identifying these word lists. wid1 identifies ** the word list that is searched first, and widn the word list that is ** searched last. The search order is unaffected. **************************************************************************/ static void getOrder(FICL_VM *pVM) { FICL_DICT *pDict = ficlGetDict(); int nLists = pDict->nLists; int i; ficlLockDictionary(TRUE); for (i = 0; i < nLists; i++) { stackPushPtr(pVM->pStack, pDict->pSearch[i]); } stackPushUNS(pVM->pStack, nLists); ficlLockDictionary(FALSE); return; } /************************************************************************** s e a r c h - w o r d l i s t ** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) ** Find the definition identified by the string c-addr u in the word list ** identified by wid. If the definition is not found, return zero. If the ** definition is found, return its execution token xt and one (1) if the ** definition is immediate, minus-one (-1) otherwise. **************************************************************************/ static void searchWordlist(FICL_VM *pVM) { STRINGINFO si; UNS16 hashCode; FICL_WORD *pFW; FICL_HASH *pHash = stackPopPtr(pVM->pStack); si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); si.cp = stackPopPtr(pVM->pStack); hashCode = hashHashCode(si); ficlLockDictionary(TRUE); pFW = hashLookup(pHash, si, hashCode); ficlLockDictionary(FALSE); if (pFW) { stackPushPtr(pVM->pStack, pFW); stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); } else { stackPushUNS(pVM->pStack, 0); } return; } /************************************************************************** s e t - c u r r e n t ** SEARCH ( wid -- ) ** Set the compilation word list to the word list identified by wid. **************************************************************************/ static void setCurrent(FICL_VM *pVM) { FICL_HASH *pHash = stackPopPtr(pVM->pStack); FICL_DICT *pDict = ficlGetDict(); ficlLockDictionary(TRUE); pDict->pCompile = pHash; ficlLockDictionary(FALSE); return; } /************************************************************************** s e t - o r d e r ** SEARCH ( widn ... wid1 n -- ) ** Set the search order to the word lists identified by widn ... wid1. ** Subsequently, word list wid1 will be searched first, and word list ** widn searched last. If n is zero, empty the search order. If n is minus ** one, set the search order to the implementation-defined minimum ** search order. The minimum search order shall include the words ** FORTH-WORDLIST and SET-ORDER. A system shall allow n to ** be at least eight. **************************************************************************/ static void setOrder(FICL_VM *pVM) { int i; int nLists = stackPopINT(pVM->pStack); FICL_DICT *dp = ficlGetDict(); if (nLists > FICL_DEFAULT_VOCS) { vmThrowErr(pVM, "set-order error: list would be too large"); } ficlLockDictionary(TRUE); if (nLists >= 0) { dp->nLists = nLists; for (i = nLists-1; i >= 0; --i) { dp->pSearch[i] = stackPopPtr(pVM->pStack); } } else { dictResetSearchOrder(dp); } ficlLockDictionary(FALSE); return; } /************************************************************************** w o r d l i s t ** SEARCH ( -- wid ) ** Create a new empty word list, returning its word list identifier wid. ** The new word list may be returned from a pool of preallocated word ** lists or may be dynamically allocated in data space. A system shall ** allow the creation of at least 8 new word lists in addition to any ** provided as part of the system. ** Notes: ** 1. ficl creates a new single-list hash in the dictionary and returns ** its address. ** 2. ficl-wordlist takes an arg off the stack indicating the number of ** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as ** : wordlist 1 ficl-wordlist ; **************************************************************************/ static void wordlist(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); FICL_HASH *pHash; FICL_UNS nBuckets; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif nBuckets = stackPopUNS(pVM->pStack); dictAlign(dp); pHash = (FICL_HASH *)dp->here; dictAllot(dp, sizeof (FICL_HASH) + (nBuckets-1) * sizeof (FICL_WORD *)); pHash->size = nBuckets; hashReset(pHash); stackPushPtr(pVM->pStack, pHash); return; } /************************************************************************** S E A R C H > ** ficl ( -- wid ) ** Pop wid off the search order. Error if the search order is empty **************************************************************************/ static void searchPop(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); int nLists; ficlLockDictionary(TRUE); nLists = dp->nLists; if (nLists == 0) { vmThrowErr(pVM, "search> error: empty search order"); } stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); ficlLockDictionary(FALSE); return; } /************************************************************************** > S E A R C H ** ficl ( wid -- ) ** Push wid onto the search order. Error if the search order is full. **************************************************************************/ static void searchPush(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); ficlLockDictionary(TRUE); if (dp->nLists > FICL_DEFAULT_VOCS) { vmThrowErr(pVM, ">search error: search order overflow"); } dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); ficlLockDictionary(FALSE); 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 = ficlGetDict(); 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); stackPushPtr(pVM->pStack, 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; stackPushPtr(pVM->pStack, &pVM->user[i]); return; } static void userVariable(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); 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 = ficlGetDict(); FICL_WORD *pFW; #if FICL_WANT_LOCALS - FICL_DICT *pLoc = ficlGetLoc(); if ((nLocals > 0) && (pVM->state == COMPILE)) { + FICL_DICT *pLoc = ficlGetLoc(); pFW = dictLookup(pLoc, si); - if (pFW) + if (pFW && (pFW->code == doLocalIm)) { dictAppendCell(dp, LVALUEtoCELL(pToLocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } + else if (pFW && pFW->code == do2LocalIm) + { + dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen)); + dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); + return; + } } #endif assert(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 */ { stackPushPtr(pVM->pStack, &pFW->param[0]); literalIm(pVM); dictAppendCell(dp, LVALUEtoCELL(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 = ficlGetDict(); 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(pGetLocal0)); } else if (nLocal == 1) { dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1)); } else { dictAppendCell(pDict, LVALUEtoCELL(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) { - static CELL *pMark = NULL; FICL_DICT *pDict = ficlGetDict(); 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 dict and update nLocals */ + { /* add a local to the **locals** dict and update nLocals */ FICL_DICT *pLoc = ficlGetLoc(); if (nLocals >= FICL_MAX_LOCALS) { vmThrowErr(pVM, "Error: out of local space"); } dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); if (nLocals == 0) { /* compile code to create a local stack frame */ dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); /* save location in dictionary for #locals */ - pMark = pDict->here; + pMarkLocals = pDict->here; dictAppendCell(pDict, LVALUEtoCELL(nLocals)); /* compile code to initialize first local */ dictAppendCell(pDict, LVALUEtoCELL(pToLocal0)); } else if (nLocals == 1) { dictAppendCell(pDict, LVALUEtoCELL(pToLocal1)); } else { dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocals)); } nLocals++; } else if (nLocals > 0) { /* write nLocals to (link) param area in dictionary */ - *(FICL_INT *)pMark = nLocals; + *(FICL_INT *)pMarkLocals = 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 = ficlGetDict(); + 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(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 = ficlGetDict(); + 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(); + if (nLocals >= FICL_MAX_LOCALS) + { + vmThrowErr(pVM, "Error: out of local space"); + } + + dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); + dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); + + if (nLocals == 0) + { /* compile code to create a local stack frame */ + dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); + /* save location in dictionary for #locals */ + pMarkLocals = pDict->here; + dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + } + + dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(nLocals)); + + nLocals += 2; + } + else if (nLocals > 0) + { /* write nLocals to (link) param area in dictionary */ + *(FICL_INT *)pMarkLocals = nLocals; + } + + return; +} + + #endif /************************************************************************** setParentWid ** FICL ** setparentwid ( parent-wid wid -- ) ** Set WID's link field to the parent-wid. search-wordlist will ** iterate through all the links when finding words in the child wid. **************************************************************************/ static void setParentWid(FICL_VM *pVM) { FICL_HASH *parent, *child; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 0); #endif child = (FICL_HASH *)stackPopPtr(pVM->pStack); parent = (FICL_HASH *)stackPopPtr(pVM->pStack); child->link = parent; return; } /************************************************************************** s e e ** TOOLS ( "name" -- ) ** Display a human-readable representation of the named word's definition. ** The source of the representation (object-code decompilation, source ** block, etc.) and the particular form of the display is implementation ** defined. ** NOTE: these funcs come late in the file because they reference all ** of the word-builder funcs without declaring them again. Call me lazy. **************************************************************************/ /* ** isAFiclWord ** Vet a candidate pointer carefully to make sure ** it's not some chunk o' inline data... ** It has to have a name, and it has to look ** like it's in the dictionary address range. ** NOTE: this excludes :noname words! */ -#ifdef FICL_TRACE -int isAFiclWord(FICL_WORD *pFW) -#else static int isAFiclWord(FICL_WORD *pFW) -#endif { FICL_DICT *pd = ficlGetDict(); if (!dictIncludes(pd, pFW)) return 0; if (!dictIncludes(pd, pFW->name)) return 0; return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0')); } /* ** seeColon (for proctologists only) ** Walks a colon definition, decompiling ** on the fly. Knows about primitive control structures. */ static void seeColon(FICL_VM *pVM, CELL *pc) { for (; pc->p != pSemiParen; pc++) { FICL_WORD *pFW = (FICL_WORD *)(pc->p); if (isAFiclWord(pFW)) { if (pFW->code == literalParen) { CELL v = *++pc; if (isAFiclWord(v.p)) { FICL_WORD *pLit = (FICL_WORD *)v.p; sprintf(pVM->pad, " literal %.*s (%#lx)", pLit->nName, pLit->name, v.u); } else sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u); } else if (pFW->code == stringLit) { FICL_STRING *sp = (FICL_STRING *)(void *)++pc; pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text); } else if (pFW->code == ifParen) { CELL c = *++pc; if (c.i > 0) sprintf(pVM->pad, " if / while (branch rel %ld)", c.i); else sprintf(pVM->pad, " until (branch rel %ld)", c.i); } else if (pFW->code == branchParen) { CELL c = *++pc; if (c.i > 0) sprintf(pVM->pad, " else (branch rel %ld)", c.i); else sprintf(pVM->pad, " repeat (branch rel %ld)", c.i); } else if (pFW->code == qDoParen) { CELL c = *++pc; sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); } else if (pFW->code == doParen) { CELL c = *++pc; sprintf(pVM->pad, " do (leave abs %#lx)", c.u); } else if (pFW->code == loopParen) { CELL c = *++pc; sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); } else if (pFW->code == plusLoopParen) { CELL c = *++pc; sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); } else /* default: print word's name */ { sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); } vmTextOut(pVM, pVM->pad, 1); } else /* probably not a word - punt and print value */ { sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u); vmTextOut(pVM, pVM->pad, 1); } } vmTextOut(pVM, ";", 1); } /* ** Here's the outer part of the decompiler. It's ** just a big nested conditional that checks the ** CFA of the word to decompile for each kind of ** known word-builder code, and tries to do ** something appropriate. If the CFA is not recognized, ** just indicate that it is a primitive. */ static void see(FICL_VM *pVM) { FICL_WORD *pFW; tick(pVM); pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); if (pFW->code == colonParen) { sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); vmTextOut(pVM, pVM->pad, 1); seeColon(pVM, pFW->param); } else if (pFW->code == doDoes) { vmTextOut(pVM, "does>", 1); seeColon(pVM, (CELL *)pFW->param->p); } else if (pFW->code == createParen) { vmTextOut(pVM, "create", 1); } else if (pFW->code == variableParen) { sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); } else if (pFW->code == userParen) { sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); } else if (pFW->code == constantParen) { sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u); vmTextOut(pVM, pVM->pad, 1); } else { vmTextOut(pVM, "primitive", 1); } if (pFW->flags & FW_IMMEDIATE) { vmTextOut(pVM, "immediate", 1); } return; } /************************************************************************** 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 compareString(FICL_VM *pVM) { 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--) { n = (int)(*cp1++ - *cp2++); } if (n == 0) n = (int)(u1 - u2); if (n < 0) n = -1; else if (n > 0) n = 1; stackPushINT(pVM->pStack, n); 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; stackPushINT(pVM->pStack, ret); if (ret) vmThrow(pVM, VM_OUTOFTEXT); return; } /************************************************************************** f o r g e t ** TOOLS EXT ( "name" -- ) ** Skip leading space delimiters. Parse name delimited by a space. ** Find name, then delete name from the dictionary along with all ** words added to the dictionary after name. An ambiguous ** condition exists if name cannot be found. ** ** If the Search-Order word set is present, FORGET searches the ** compilation word list. An ambiguous condition exists if the ** compilation word list is deleted. **************************************************************************/ static void forgetWid(FICL_VM *pVM) { FICL_DICT *pDict = ficlGetDict(); FICL_HASH *pHash; pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); hashForget(pHash, pDict->here); return; } static void forget(FICL_VM *pVM) { void *where; FICL_DICT *pDict = ficlGetDict(); FICL_HASH *pHash = pDict->pCompile; tick(pVM); where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; hashForget(pHash, where); pDict->here = PTRtoCELL where; return; } /************************* freebsd added I/O words **************************/ /* fopen - open a file and return new fd on stack. * * fopen ( count ptr -- fd ) */ static void pfopen(FICL_VM *pVM) { int fd; char *p; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif (void)stackPopINT(pVM->pStack); /* don't need count value */ p = stackPopPtr(pVM->pStack); fd = open(p, O_RDONLY); stackPushINT(pVM->pStack, fd); return; } /* fclose - close a file who's fd is on stack. * * fclose ( fd -- ) */ static void pfclose(FICL_VM *pVM) { int fd; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif fd = stackPopINT(pVM->pStack); /* get fd */ if (fd != -1) close(fd); return; } /* fread - read file contents * * fread ( fd buf nbytes -- nread ) */ static void pfread(FICL_VM *pVM) { int fd, len; char *buf; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 1); #endif len = stackPopINT(pVM->pStack); /* get number of bytes to read */ buf = stackPopPtr(pVM->pStack); /* get buffer */ fd = stackPopINT(pVM->pStack); /* get fd */ if (len > 0 && buf && fd != -1) stackPushINT(pVM->pStack, read(fd, buf, len)); else stackPushINT(pVM->pStack, -1); return; } /* fload - interpret file contents * * fload ( fd -- ) */ static void pfload(FICL_VM *pVM) { int fd; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif fd = stackPopINT(pVM->pStack); /* get fd */ if (fd != -1) ficlExecFD(pVM, fd); return; } /* key - get a character from stdin * * key ( -- char ) */ static void key(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif stackPushINT(pVM->pStack, getchar()); return; } /* key? - check for a character from stdin (FACILITY) * * key? ( -- flag ) */ static void keyQuestion(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif #ifdef TESTMAIN /* XXX Since we don't fiddle with termios, let it always succeed... */ stackPushINT(pVM->pStack, FICL_TRUE); #else /* But here do the right thing. */ stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE); #endif return; } /* seconds - gives number of seconds since beginning of time * * beginning of time is defined as: * * BTX - number of seconds since midnight * FreeBSD - number of seconds since Jan 1 1970 * * seconds ( -- u ) */ static void pseconds(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM,0,1); #endif stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL)); return; } /* ms - wait at least that many milliseconds (FACILITY) * * ms ( u -- ) * */ static void ms(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM,1,0); #endif #ifdef TESTMAIN usleep(stackPopUNS(pVM->pStack)*1000); #else delay(stackPopUNS(pVM->pStack)*1000); #endif return; } /* fkey - get a character from a file * * fkey ( file -- char ) */ static void fkey(FICL_VM *pVM) { int i, fd; char ch; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif fd = stackPopINT(pVM->pStack); i = read(fd, &ch, 1); stackPushINT(pVM->pStack, i > 0 ? ch : -1); 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. ** -** BUGS: do not handle locals unnesting correctly... I think... -** ** Daniel C. Sobral Jan 09/1999 +** sadler may 2000 -- revised to follow ficl.c:ficlExecXT. **************************************************************************/ static void ficlCatch(FICL_VM *pVM) { - int except; + static FICL_WORD *pQuit = NULL; + + int except; jmp_buf vmState; FICL_VM VM; FICL_STACK pStack; FICL_STACK rStack; FICL_WORD *pFW; - IPTYPE exitIP; + if (!pQuit) + pQuit = ficlLookup("exit-inner"); + + assert(pVM); + assert(pQuit); + + /* ** 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); - /* - ** And now, choose what to do depending on except. - */ + 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, &pQuit); /* Open mouth, insert emetic */ + vmExecute(pVM, pFW); + vmInnerLoop(pVM); + break; - /* Things having gone wrong... */ - if(except) - { + /* + ** 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 */ + stackPushINT(pVM->pStack, 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)); - /* Push error */ - stackPushINT(pVM->pStack, except); - - } - else /* Things being ok... */ - { - /* - * We need to know when to exit the inner loop - * Colonp, the "code" for colon words, just pushes - * the word's IP onto the RP, and expect the inner - * interpreter to do the rest. Well, I'd rather have - * it done *before* I return from this function, - * losing the automatic variables I'm using to save - * state. Sure, I could save this on dynamic memory - * and save state on RP, or I could even implement - * the poor man's version of this word in Forth with - * sp@, sp!, rp@ and rp!, but we have a lot of state - * neatly tucked away in pVM, so why not save it? - */ - exitIP = pVM->ip; - - /* Execute the xt -- inline code for vmExecute */ - - pVM->runningWord = pFW; - pFW->code(pVM); - - /* - ** Run the inner loop until we get back to exitIP - */ - for (; pVM->ip != exitIP;) - { - pFW = *pVM->ip++; - - /* Inline code for vmExecute */ - pVM->runningWord = pFW; - pFW->code(pVM); - } - - - /* Restore just the setjmp vector */ - pVM->pState = VM.pState; - - /* Push 0 -- everything is ok */ - stackPushINT(pVM->pStack, 0); - } + stackPushINT(pVM->pStack, except);/* Push error */ + break; + } } /* * 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); } -/*************** freebsd added memory-alloc handling words ******************/ - static void ansAllocate(FICL_VM *pVM) { size_t size; void *p; size = stackPopINT(pVM->pStack); p = ficlMalloc(size); stackPushPtr(pVM->pStack, p); if (p) stackPushINT(pVM->pStack, 0); else stackPushINT(pVM->pStack, 1); } static void ansFree(FICL_VM *pVM) { void *p; p = stackPopPtr(pVM->pStack); ficlFree(p); stackPushINT(pVM->pStack, 0); } 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) { stackPushPtr(pVM->pStack, new); stackPushINT(pVM->pStack, 0); } else { stackPushPtr(pVM->pStack, old); stackPushINT(pVM->pStack, 1); } } /* ** Retrieves free space remaining on the dictionary */ static void freeHeap(FICL_VM *pVM) { stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict())); } /* ** exit-inner ** 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; } /******************* Increase dictionary size on-demand ******************/ static void ficlDictThreshold(FICL_VM *pVM) { stackPushPtr(pVM->pStack, &dictThreshold); } static void ficlDictIncrease(FICL_VM *pVM) { stackPushPtr(pVM->pStack, &dictIncrease); } /************************* freebsd added trace ***************************/ #ifdef FICL_TRACE static void ficlTrace(FICL_VM *pVM) { #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif ficl_trace = stackPopINT(pVM->pStack); } #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_DICT *dp) { assert (dp); /* ** CORE word set ** see softcore.c for definitions of: abs bl space spaces abort" */ pStore = dictAppendWord(dp, "!", store, FW_DEFAULT); dictAppendWord(dp, "#", numberSign, FW_DEFAULT); dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); dictAppendWord(dp, "\'", tick, 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); pComma = dictAppendWord(dp, ",", comma, FW_DEFAULT); dictAppendWord(dp, "-", sub, FW_DEFAULT); dictAppendWord(dp, ".", displayCell, FW_DEFAULT); dictAppendWord(dp, ".#", displayCellNoPad, 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, "0>", zeroGreater, 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_DEFAULT); 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, "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); 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, "environment?", environmentQ,FW_DEFAULT); dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); dictAppendWord(dp, "execute", execute, FW_DEFAULT); dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); dictAppendWord(dp, "fill", fill, FW_DEFAULT); dictAppendWord(dp, "find", find, FW_DEFAULT); dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); dictAppendWord(dp, "here", here, FW_DEFAULT); dictAppendWord(dp, "hex", hex, 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, "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_DEFAULT); dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT); 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); pType = dictAppendWord(dp, "type", type, FW_DEFAULT); dictAppendWord(dp, "u.", uDot, FW_DEFAULT); dictAppendWord(dp, "u<", uIsLess, 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.c for other definitions */ dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); + dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); dictAppendWord(dp, "parse", parse, FW_DEFAULT); dictAppendWord(dp, "pick", pick, FW_DEFAULT); dictAppendWord(dp, "roll", roll, FW_DEFAULT); dictAppendWord(dp, "refill", refill, FW_DEFAULT); dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); dictAppendWord(dp, "value", constant, FW_DEFAULT); dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); /* FreeBSD extension words */ dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT); dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT); dictAppendWord(dp, "fread", pfread, FW_DEFAULT); dictAppendWord(dp, "fload", pfload, FW_DEFAULT); dictAppendWord(dp, "fkey", fkey, FW_DEFAULT); dictAppendWord(dp, "key", key, FW_DEFAULT); dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT); dictAppendWord(dp, "ms", ms, FW_DEFAULT); dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT); dictAppendWord(dp, "heap?", freeHeap, FW_DEFAULT); dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT); dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT); #ifdef FICL_TRACE dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT); #endif #ifndef TESTMAIN #ifdef __i386__ dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT); dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT); #endif #endif #if defined(__i386__) ficlSetEnv("arch-i386", FICL_TRUE); ficlSetEnv("arch-alpha", FICL_FALSE); #elif defined(__alpha__) ficlSetEnv("arch-i386", FICL_FALSE); ficlSetEnv("arch-alpha", FICL_TRUE); #endif /* ** Set CORE environment query values */ ficlSetEnv("/counted-string", FICL_STRING_MAX); ficlSetEnv("/hold", nPAD); ficlSetEnv("/pad", nPAD); ficlSetEnv("address-unit-bits", 8); ficlSetEnv("core", FICL_TRUE); ficlSetEnv("core-ext", FICL_FALSE); ficlSetEnv("floored", FICL_FALSE); ficlSetEnv("max-char", UCHAR_MAX); ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff ); ficlSetEnv("max-n", 0x7fffffff); ficlSetEnv("max-u", 0xffffffff); ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff); ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK); ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); /* + ** DOUBLE word set (partial) + */ + dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); + dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); + dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); + + + /* ** EXCEPTION word set */ dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); ficlSetEnv("exception", FICL_TRUE); ficlSetEnv("exception-ext", FICL_TRUE); /* ** LOCAL and LOCAL EXT ** see softcore.c for implementation of locals| */ #if FICL_WANT_LOCALS pLinkParen = dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); pUnLinkParen = dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); pGetLocalParen = dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); pToLocalParen = dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); pGetLocal0 = dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); pToLocal0 = dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); pGetLocal1 = dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); pToLocal1 = dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); dictAppendWord(dp, "(local)", localParen, FW_COMPILE); + pGet2LocalParen = + dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); + pTo2LocalParen = + dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); + dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); + ficlSetEnv("locals", FICL_TRUE); ficlSetEnv("locals-ext", FICL_TRUE); ficlSetEnv("#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("memory-alloc", FICL_TRUE); ficlSetEnv("memory-alloc-ext", FICL_FALSE); /* ** optional SEARCH-ORDER word set */ dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); dictAppendWord(dp, "definitions", definitions, FW_DEFAULT); dictAppendWord(dp, "forth-wordlist", forthWordlist, FW_DEFAULT); dictAppendWord(dp, "get-current", getCurrent, FW_DEFAULT); dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); dictAppendWord(dp, "search-wordlist", searchWordlist, FW_DEFAULT); dictAppendWord(dp, "set-current", setCurrent, FW_DEFAULT); dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT); /* ** Set SEARCH environment query values */ ficlSetEnv("search-order", FICL_TRUE); ficlSetEnv("search-order-ext", FICL_TRUE); ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); /* ** TOOLS and TOOLS EXT */ dictAppendWord(dp, ".s", displayStack, FW_DEFAULT); dictAppendWord(dp, "bye", bye, FW_DEFAULT); dictAppendWord(dp, "forget", forget, FW_DEFAULT); dictAppendWord(dp, "see", see, FW_DEFAULT); dictAppendWord(dp, "words", listWords, FW_DEFAULT); /* ** Set TOOLS environment query values */ ficlSetEnv("tools", FICL_TRUE); ficlSetEnv("tools-ext", FICL_FALSE); /* ** Ficl extras */ dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); - dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */ dictAppendWord(dp, ">name", toName, FW_DEFAULT); dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compile-only", compileOnly, FW_DEFAULT); - dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); /* DOUBLE */ dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); + dictAppendWord(dp, "hash", hash, FW_DEFAULT); + dictAppendWord(dp, "number?", ficlIsNum, FW_DEFAULT); dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ dictAppendWord(dp, "wid-set-super", setParentWid, 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 /* ** internal support words */ pExitParen = dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); pSemiParen = dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); pLitParen = dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); + pTwoLitParen = + dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); pStringLit = dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); pIfParen = dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); pBranchParen = dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); pDoParen = dictAppendWord(dp, "(do)", doParen, FW_COMPILE); pDoesParen = dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); pQDoParen = dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); pLoopParen = dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); pPLoopParen = dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); pInterpret = dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); assert(dictCellsAvail(dp) > 0); return; }