diff options
author | dcs <dcs@FreeBSD.org> | 2001-04-29 02:36:36 +0000 |
---|---|---|
committer | dcs <dcs@FreeBSD.org> | 2001-04-29 02:36:36 +0000 |
commit | 1e7d7fa08115fc164f8ace561bcb994a5e67b77f (patch) | |
tree | 690032d340b3613edf94f5cc9c0fd8ae2c6c2487 /sys/boot/ficl | |
parent | 92d7ad4004a51f2ffc4e8141df3233065f426cfd (diff) | |
download | FreeBSD-src-1e7d7fa08115fc164f8ace561bcb994a5e67b77f.zip FreeBSD-src-1e7d7fa08115fc164f8ace561bcb994a5e67b77f.tar.gz |
Bring in ficl 2.05.
This version has a step debugger, which now completely replaces the
old trace feature. Also, we moved all of the FreeBSD-specific MI
code to loader.c, reducing the diff between this and the official
FICL distribution.
Diffstat (limited to 'sys/boot/ficl')
26 files changed, 3992 insertions, 1804 deletions
diff --git a/sys/boot/ficl/Makefile b/sys/boot/ficl/Makefile index d6db6ae..b80ff97 100644 --- a/sys/boot/ficl/Makefile +++ b/sys/boot/ficl/Makefile @@ -1,7 +1,8 @@ # $FreeBSD$ # .PATH: ${.CURDIR}/${MACHINE_ARCH} -BASE_SRCS= dict.c ficl.c math64.c stack.c vm.c words.c +BASE_SRCS= dict.c ficl.c math64.c search.c stack.c tools.c \ + prefix.c loader.c vm.c words.c SRCS= ${BASE_SRCS} sysdep.c softcore.c CLEANFILES= softcore.c testmain testmain.o .if ${MACHINE_ARCH} == "alpha" @@ -23,7 +24,6 @@ LIB= ficl INTERNALLIB= yes INTERNALSTATICLIB= yes NOPROFILE= yes -SRCS+= loader.c .include <bsd.lib.mk> .endif @@ -34,7 +34,7 @@ SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr ficllocal.fr \ #SOFTWORDS+= oo.fr classes.fr .PATH: ${.CURDIR}/softwords -CFLAGS+= -I${.CURDIR} -I${.CURDIR}/${MACHINE_ARCH} -I${.CURDIR}/../common -DFICL_TRACE +CFLAGS+= -I${.CURDIR} -I${.CURDIR}/${MACHINE_ARCH} -I${.CURDIR}/../common softcore.c: ${SOFTWORDS} softcore.awk (cd ${.CURDIR}/softwords; cat ${SOFTWORDS} \ diff --git a/sys/boot/ficl/alpha/sysdep.h b/sys/boot/ficl/alpha/sysdep.h index 1803352..0a6ca33 100644 --- a/sys/boot/ficl/alpha/sysdep.h +++ b/sys/boot/ficl/alpha/sysdep.h @@ -9,27 +9,43 @@ ** FICL_ROBUST is enabled. This may require some consideration ** in firmware systems since assert often ** assumes stderr/stdout. -** +** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ *******************************************************************/ /* -** 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 not supported. -** -** 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. +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R ** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** ** 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. +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -41,14 +57,12 @@ #include <stddef.h> /* size_t, NULL */ #include <setjmp.h> - #include <assert.h> #if !defined IGNORE /* Macro to silence unused param warnings */ #define IGNORE(x) &x #endif - /* ** TRUE and FALSE for C boolean operations, and ** portable 32 bit types for CELLs @@ -89,6 +103,7 @@ ** FICL_UNS and FICL_INT must have the same size as a void* on ** the target system. A CELL is a union of void*, FICL_UNS, and ** FICL_INT. +** (11/2000: same for FICL_FLOAT) */ #if !defined FICL_INT #define FICL_INT long @@ -98,6 +113,10 @@ #define FICL_UNS unsigned long #endif +#if !defined FICL_FLOAT +#define FICL_FLOAT float +#endif + /* ** Ficl presently supports values of 32 and 64 for BITS_PER_CELL */ @@ -135,9 +154,108 @@ typedef struct /* -** Build controls +** B U I L D C O N T R O L S +*/ + +#if !defined (FICL_MINIMAL) +#define FICL_MINIMAL 0 +#endif +#if (FICL_MINIMAL) +#define FICL_WANT_SOFTWORDS 0 +#define FICL_WANT_FLOAT 0 +#define FICL_WANT_USER 0 +#define FICL_WANT_LOCALS 0 +#define FICL_WANT_DEBUGGER 0 +#define FICL_WANT_OOP 0 +#define FICL_PLATFORM_EXTEND 0 +#define FICL_MULTITHREAD 0 +#define FICL_ROBUST 0 +#define FICL_EXTENDED_PREFIX 0 +#endif + +/* +** FICL_PLATFORM_EXTEND +** Includes words defined in ficlCompilePlatform +*/ +#if !defined (FICL_PLATFORM_EXTEND) +#define FICL_PLATFORM_EXTEND 1 +#endif + +/* +** FICL_WANT_FLOAT +** Includes a floating point stack for the VM, and words to do float operations. +** Contributed by Guy Carver +*/ +#if !defined (FICL_WANT_FLOAT) +#define FICL_WANT_FLOAT 0 +#endif + +/* +** FICL_WANT_DEBUGGER +** Inludes a simple source level debugger +*/ +#if !defined (FICL_WANT_DEBUGGER) +#define FICL_WANT_DEBUGGER 1 +#endif + +/* +** User variables: per-instance variables bound to the VM. +** Kinda like thread-local storage. Could be implemented in a +** VM private dictionary, but I've chosen the lower overhead +** approach of an array of CELLs instead. +*/ +#if !defined FICL_WANT_USER +#define FICL_WANT_USER 1 +#endif + +#if !defined FICL_USER_CELLS +#define FICL_USER_CELLS 16 +#endif + +/* +** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and +** a private dictionary for local variable compilation. +*/ +#if !defined FICL_WANT_LOCALS +#define FICL_WANT_LOCALS 1 +#endif + +/* Max number of local variables per definition */ +#if !defined FICL_MAX_LOCALS +#define FICL_MAX_LOCALS 16 +#endif + +/* +** FICL_WANT_OOP +** Inludes object oriented programming support (in softwords) +** OOP support requires locals and user variables! +*/ +#if !(FICL_WANT_LOCALS) || !(FICL_WANT_USER) +#if !defined (FICL_WANT_OOP) +#define FICL_WANT_OOP 0 +#endif +#endif + +#if !defined (FICL_WANT_OOP) +#define FICL_WANT_OOP 1 +#endif + +/* +** FICL_WANT_SOFTWORDS +** Controls inclusion of all softwords in softcore.c +*/ +#if !defined (FICL_WANT_SOFTWORDS) +#define FICL_WANT_SOFTWORDS 1 +#endif + +/* ** FICL_MULTITHREAD enables dictionary mutual exclusion ** wia the ficlLockDictionary system dependent function. +** Note: this implementation is experimental and poorly +** tested. Further, it's unnecessary unless you really +** intend to have multiple SESSIONS (poor choice of name +** on my part) - that is, threads that modify the dictionary +** at the same time. */ #if !defined FICL_MULTITHREAD #define FICL_MULTITHREAD 0 @@ -152,7 +270,6 @@ typedef struct #define PORTABLE_LONGMULDIV 0 #endif - /* ** INLINE_INNER_LOOP causes the inner interpreter to be inline code ** instead of a function call. This is mainly because MS VC++ 5 @@ -214,30 +331,21 @@ typedef struct #endif /* -** User variables: per-instance variables bound to the VM. -** Kinda like thread-local storage. Could be implemented in a -** VM private dictionary, but I've chosen the lower overhead -** approach of an array of CELLs instead. +** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure +** that stores pointers to parser extension functions. I would never expect to have +** more than 8 of these, so that's the default limit. Too many of these functions +** will probably exact a nasty performance penalty. */ -#if !defined FICL_WANT_USER -#define FICL_WANT_USER 1 -#endif - -#if !defined FICL_USER_CELLS -#define FICL_USER_CELLS 16 +#if !defined FICL_MAX_PARSE_STEPS +#define FICL_MAX_PARSE_STEPS 8 #endif -/* -** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and -** a private dictionary for local variable compilation. +/* +** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if +** included as part of softcore.c) */ -#if !defined FICL_WANT_LOCALS -#define FICL_WANT_LOCALS 1 -#endif - -/* Max number of local variables per definition */ -#if !defined FICL_MAX_LOCALS -#define FICL_MAX_LOCALS 16 +#if !defined FICL_EXTENDED_PREFIX +#define FICL_EXTENDED_PREFIX 0 #endif /* diff --git a/sys/boot/ficl/dict.c b/sys/boot/ficl/dict.c index d12428c..e5fdb2b 100644 --- a/sys/boot/ficl/dict.c +++ b/sys/boot/ficl/dict.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - dictionary methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** +** $Id: dict.c,v 1.6 2000-06-17 07:43:44-07 jsadler Exp jsadler $ *******************************************************************/ /* ** This file implements the dictionary -- FICL's model of @@ -16,6 +16,42 @@ ** ** 29 jun 1998 (sadler) added variable sized hash table support */ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: dict.c,v 1.8 2001-04-26 21:41:45-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -270,14 +306,14 @@ int dictCellsUsed(FICL_DICT *pDict) ** Checks the dictionary for corruption and throws appropriate ** errors **************************************************************************/ -void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n) +void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells) { - if ((n >= 0) && (dictCellsAvail(pDict) * sizeof (CELL) < n)) + if ((nCells >= 0) && (dictCellsAvail(pDict) < nCells)) { vmThrowErr(pVM, "Error: dictionary full"); } - if ((n <= 0) && (dictCellsUsed(pDict) * sizeof (CELL) < -n)) + if ((nCells <= 0) && (dictCellsUsed(pDict) < -nCells)) { vmThrowErr(pVM, "Error: dictionary underflow"); } @@ -367,6 +403,25 @@ FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash) /************************************************************************** + d i c t C r e a t e W o r d l i s t +** Create and initialize an anonymous wordlist +**************************************************************************/ +FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets) +{ + FICL_HASH *pHash; + + dictAlign(dp); + pHash = (FICL_HASH *)dp->here; + dictAllot(dp, sizeof (FICL_HASH) + + (nBuckets-1) * sizeof (FICL_WORD *)); + + pHash->size = nBuckets; + hashReset(pHash); + return pHash; +} + + +/************************************************************************** d i c t D e l e t e ** Free all memory allocated for the given dictionary **************************************************************************/ @@ -606,7 +661,8 @@ UNS16 hashHashCode(STRINGINFO si) if (si.count == 0) return 0; - for (cp = (UNS8 *)si.cp; *cp && si.count; cp++, si.count--) + /* changed to run without errors under Purify -- lch */ + for (cp = (UNS8 *)si.cp; si.count && *cp; cp++, si.count--) { code = (UNS16)((code << 4) + tolower(*cp)); shift = (UNS16)(code & 0xf000); @@ -621,6 +677,8 @@ UNS16 hashHashCode(STRINGINFO si) } + + /************************************************************************** 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 @@ -659,7 +717,7 @@ void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW) **************************************************************************/ FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode) { - FICL_COUNT nCmp = (FICL_COUNT)si.count; + FICL_UNS nCmp = si.count; FICL_WORD *pFW; UNS16 hashIdx; @@ -704,6 +762,7 @@ void hashReset(FICL_HASH *pHash) } pHash->link = NULL; + pHash->name = NULL; return; } diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c index 17b9acb..d5ce084 100644 --- a/sys/boot/ficl/ficl.c +++ b/sys/boot/ficl/ficl.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - external interface ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** +** $Id: ficl.c,v 1.10 2001-04-26 21:41:42-07 jsadler Exp jsadler $ *******************************************************************/ /* ** This is an ANS Forth interpreter written in C. @@ -15,11 +15,47 @@ ** 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. +** text block, so the data pump is somewhere in external code in the +** style of TCL. ** ** Code is written in ANSI C for portability. */ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: ficl.c,v 1.10 2001-04-26 21:41:42-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -31,15 +67,6 @@ #include <string.h> #include "ficl.h" -#ifdef FICL_TRACE -int ficl_trace = 0; -#endif - - -/* -** Local prototypes -*/ - /* ** System statics @@ -52,12 +79,7 @@ int ficl_trace = 0; ** 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 FICL_SYSTEM *pSys = NULL; static int defaultStack = FICL_DEFAULT_STACK; static int defaultDict = FICL_DEFAULT_DICT; @@ -76,22 +98,20 @@ static int defaultDict = FICL_DEFAULT_DICT; **************************************************************************/ void ficlInitSystem(int nDictCells) { - if (dp) - dictDelete(dp); + pSys = ficlMalloc(sizeof (FICL_SYSTEM)); + assert(pSys); - if (envp) - dictDelete(envp); - -#if FICL_WANT_LOCALS - if (localp) - dictDelete(localp); -#endif + memset(pSys, 0, sizeof (FICL_SYSTEM)); if (nDictCells <= 0) nDictCells = defaultDict; - dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE); - envp = dictCreate( (unsigned)FICL_DEFAULT_ENV); + pSys->dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE); + pSys->dp->pForthWords->name = "forth-wordlist"; + + pSys->envp = dictCreate((unsigned)FICL_DEFAULT_ENV); + pSys->envp->pForthWords->name = "environment"; + #if FICL_WANT_LOCALS /* ** The locals dictionary is only searched while compiling, @@ -100,11 +120,103 @@ void ficlInitSystem(int nDictCells) ** 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); + pSys->localp = dictCreate((unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD); +#endif + + /* + ** Establish the parse order. Note that prefixes precede numbers - + ** this allows constructs like "0b101010" which would parse as a + ** valid hex value otherwise. + */ + ficlCompilePrefix(pSys); + ficlAddPrecompiledParseStep(pSys, "number?", ficlParseNumber); + + /* + ** Build the precompiled dictionary and load softwords. We need a temporary + ** VM to do this - ficlNewVM links one to the head of the system VM list. + ** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words. + */ + ficlCompileCore(pSys); +#if FICL_WANT_FLOAT + ficlCompileFloat(pSys); #endif - ficlCompileCore(dp); +#if FICL_PLATFORM_EXTEND + ficlCompilePlatform(pSys); +#endif + + /* + ** Now we can create a VM to compile the softwords. Note that the VM initialization + ** code needs to be able to find "interpret" in the dictionary in order to + ** succeed, so as presently constructed ficlCompileCore has to finish before + ** a VM can be created successfully. + */ + ficlNewVM(); + ficlCompileSoftCore(pSys); + ficlFreeVM(pSys->vmList); + + + return; +} + + +/************************************************************************** + f i c l A d d P a r s e S t e p +** Appends a parse step function to the end of the parse list (see +** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful, +** nonzero if there's no more room in the list. +**************************************************************************/ +int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW) +{ + int i; + for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) + { + if (pSys->parseList[i] == NULL) + { + pSys->parseList[i] = pFW; + return 0; + } + } + + return 1; +} + + +/* +** Compile a word into the dictionary that invokes the specified FICL_PARSE_STEP +** function. It is up to the user (as usual in Forth) to make sure the stack +** preconditions are valid (there needs to be a counted string on top of the stack) +** before using the resulting word. +*/ +void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep) +{ + FICL_DICT *dp = pSys->dp; + FICL_WORD *pFW = dictAppendWord(dp, name, parseStepParen, FW_DEFAULT); + dictAppendCell(dp, LVALUEtoCELL(pStep)); + ficlAddParseStep(pSys, pFW); +} + +/* +** This word lists the parse steps in order +*/ +void ficlListParseSteps(FICL_VM *pVM) +{ + int i; + FICL_SYSTEM *pSys = pVM->pSys; + assert(pSys); + + vmTextOut(pVM, "Parse steps:", 1); + vmTextOut(pVM, "lookup", 1); + + for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) + { + if (pSys->parseList[i] != NULL) + { + vmTextOut(pVM, pSys->parseList[i]->name, 1); + } + else break; + } return; } @@ -112,21 +224,15 @@ void ficlInitSystem(int nDictCells) /************************************************************************** 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 +** of VMs for later cleanup by ficlTermSystem. **************************************************************************/ FICL_VM *ficlNewVM(void) { FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack); - pVM->link = vmList; + pVM->link = pSys->vmList; + pVM->pSys = pSys; - /* - ** Borrow the first vm to build the soft words in softcore.c - */ - if (vmList == NULL) - ficlCompileSoftCore(pVM); - - vmList = pVM; + pSys->vmList = pVM; return pVM; } @@ -140,26 +246,26 @@ FICL_VM *ficlNewVM(void) **************************************************************************/ 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; + FICL_VM *pList = pSys->vmList; + + assert(pVM != 0); + + if (pSys->vmList == pVM) + { + pSys->vmList = pSys->vmList->link; + } + else for (; pList != NULL; pList = pList->link) + { + if (pList->link == pVM) + { + pList->link = pVM->link; + break; + } + } + + if (pList) + vmDelete(pVM); + return; } @@ -180,14 +286,14 @@ void ficlFreeVM(FICL_VM *pVM) **************************************************************************/ int ficlBuild(char *name, FICL_CODE code, char flags) { - int err = ficlLockDictionary(TRUE); - if (err) return err; + int err = ficlLockDictionary(TRUE); + if (err) return err; - assert(dictCellsAvail(dp) > sizeof (FICL_WORD) / sizeof (CELL)); - dictAppendWord(dp, name, code, flags); + assert(dictCellsAvail(pSys->dp) > sizeof (FICL_WORD) / sizeof (CELL)); + dictAppendWord(pSys->dp, name, code, flags); - ficlLockDictionary(FALSE); - return 0; + ficlLockDictionary(FALSE); + return 0; } @@ -216,17 +322,22 @@ int ficlExec(FICL_VM *pVM, char *pText) int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) { - static FICL_WORD *pInterp = NULL; + FICL_WORD **pInterp = pSys->pInterp; + FICL_DICT *dp = pSys->dp; int except; jmp_buf vmState; jmp_buf *oldState; TIB saveTib; - if (!pInterp) - pInterp = ficlLookup("interpret"); + if (!pInterp[0]) + { + pInterp[0] = ficlLookup("interpret"); + pInterp[1] = ficlLookup("(branch)"); + pInterp[2] = (FICL_WORD *)(void *)(-2); + } - assert(pInterp); + assert(pInterp[0]); assert(pVM); if (size < 0) @@ -246,12 +357,12 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) case 0: if (pVM->fRestart) { - pVM->fRestart = 0; pVM->runningWord->code(pVM); + pVM->fRestart = 0; } else { /* set VM up to interpret text */ - vmPushIP(pVM, &pInterp); + vmPushIP(pVM, &pInterp[0]); } vmInnerLoop(pVM); @@ -272,6 +383,7 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) case VM_USEREXIT: case VM_INNEREXIT: + case VM_BREAK: break; case VM_QUIT: @@ -279,7 +391,7 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) { dictAbortDefinition(dp); #if FICL_WANT_LOCALS - dictEmpty(localp, localp->pForthWords->size); + dictEmpty(pSys->localp, pSys->localp->pForthWords->size); #endif } vmQuit(pVM); @@ -293,7 +405,7 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) { dictAbortDefinition(dp); #if FICL_WANT_LOCALS - dictEmpty(localp, localp->pForthWords->size); + dictEmpty(pSys->localp, pSys->localp->pForthWords->size); #endif } dictResetSearchOrder(dp); @@ -306,53 +418,6 @@ int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) 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 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 == -1 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 @@ -377,6 +442,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) int except; jmp_buf vmState; jmp_buf *oldState; + FICL_WORD *oldRunningWord; if (!pQuit) pQuit = ficlLookup("exit-inner"); @@ -384,6 +450,11 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) assert(pVM); assert(pQuit); + /* + ** Save the runningword so that RESTART behaves correctly + ** over nested calls. + */ + oldRunningWord = pVM->runningWord; /* ** Save and restore VM's jmp_buf to enable nested calls */ @@ -404,6 +475,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) break; case VM_INNEREXIT: + case VM_BREAK: break; case VM_RESTART: @@ -423,6 +495,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) } pVM->pState = oldState; + pVM->runningWord = oldRunningWord; return (except); } @@ -437,7 +510,7 @@ FICL_WORD *ficlLookup(char *name) { STRINGINFO si; SI_PSZ(si, name); - return dictLookup(dp, si); + return dictLookup(pSys->dp, si); } @@ -447,7 +520,7 @@ FICL_WORD *ficlLookup(char *name) **************************************************************************/ FICL_DICT *ficlGetDict(void) { - return dp; + return pSys->dp; } @@ -457,7 +530,7 @@ FICL_DICT *ficlGetDict(void) **************************************************************************/ FICL_DICT *ficlGetEnv(void) { - return envp; + return pSys->envp; } @@ -470,6 +543,7 @@ void ficlSetEnv(char *name, FICL_UNS value) { STRINGINFO si; FICL_WORD *pFW; + FICL_DICT *envp = pSys->envp; SI_PSZ(si, name); pFW = dictLookup(envp, si); @@ -491,6 +565,7 @@ void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) { FICL_WORD *pFW; STRINGINFO si; + FICL_DICT *envp = pSys->envp; SI_PSZ(si, name); pFW = dictLookup(envp, si); @@ -518,7 +593,7 @@ void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) #if FICL_WANT_LOCALS FICL_DICT *ficlGetLoc(void) { - return localp; + return pSys->localp; } #endif @@ -547,27 +622,29 @@ int ficlSetStackSize(int nStackCells) **************************************************************************/ void ficlTermSystem(void) { - if (dp) - dictDelete(dp); - dp = NULL; + if (pSys->dp) + dictDelete(pSys->dp); + pSys->dp = NULL; - if (envp) - dictDelete(envp); - envp = NULL; + if (pSys->envp) + dictDelete(pSys->envp); + pSys->envp = NULL; #if FICL_WANT_LOCALS - if (localp) - dictDelete(localp); - localp = NULL; + if (pSys->localp) + dictDelete(pSys->localp); + pSys->localp = NULL; #endif - while (vmList != NULL) + while (pSys->vmList != NULL) { - FICL_VM *pVM = vmList; - vmList = vmList->link; + FICL_VM *pVM = pSys->vmList; + pSys->vmList = pSys->vmList->link; vmDelete(pVM); } + ficlFree(pSys); + pSys = NULL; return; } diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h index fe041ad..057b08e 100644 --- a/sys/boot/ficl/ficl.h +++ b/sys/boot/ficl/ficl.h @@ -3,28 +3,43 @@ ** Forth Inspired Command Language ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** +** $Id: ficl.h,v 1.11 2001-04-26 21:41:48-07 jsadler Exp jsadler $ *******************************************************************/ /* -** 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. +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R ** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** ** 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. +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: ficl.h,v 1.11 2001-04-26 21:41:48-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -215,11 +230,13 @@ extern "C" { struct ficl_word; struct vm; struct ficl_dict; +struct ficl_system; +typedef struct ficl_system FICL_SYSTEM; /* ** the Good Stuff starts here... */ -#define FICL_VER "2.03" +#define FICL_VER "2.05" #if !defined (FICL_PROMPT) #define FICL_PROMPT "ok> " #endif @@ -229,7 +246,7 @@ struct ficl_dict; ** complement of false... that unifies logical and bitwise operations ** nicely. */ -#define FICL_TRUE (~(0L)) +#define FICL_TRUE ((unsigned long)~(0L)) #define FICL_FALSE (0) #define FICL_BOOL(x) ((x) ? FICL_TRUE : FICL_FALSE) @@ -241,9 +258,13 @@ struct ficl_dict; */ typedef union _cell { - FICL_INT i; + FICL_INT i; FICL_UNS u; - void *p; +#if (FICL_WANT_FLOAT) + FICL_FLOAT f; +#endif + void *p; + void (*fn)(void); } CELL; /* @@ -301,7 +322,7 @@ typedef struct {si.cp = pfs->text; si.count = pfs->count;} /* -** Ficl uses a this little structure to hold the address of +** Ficl uses 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. @@ -336,7 +357,7 @@ 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 */ + CELL base[1]; /* Top of stack */ } FICL_STACK; /* @@ -351,7 +372,7 @@ 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); +void *stackPopPtr(FICL_STACK *pStack); FICL_UNS stackPopUNS(FICL_STACK *pStack); FICL_INT stackPopINT(FICL_STACK *pStack); void stackPush (FICL_STACK *pStack, CELL c); @@ -364,6 +385,38 @@ void stackSetTop(FICL_STACK *pStack, CELL c); void stackStore (FICL_STACK *pStack, int n, CELL c); void stackUnlink(FICL_STACK *pStack); +#if (FICL_WANT_FLOAT) +float stackPopFloat (FICL_STACK *pStack); +void stackPushFloat(FICL_STACK *pStack, float f); +#endif + +/* +** Shortcuts (Guy Carver) +*/ +#define PUSHPTR(p) stackPushPtr(pVM->pStack,p) +#define PUSHUNS(u) stackPushUNS(pVM->pStack,u) +#define PUSHINT(i) stackPushINT(pVM->pStack,i) +#define PUSHFLOAT(f) stackPushFloat(pVM->fStack,f) +#define PUSH(c) stackPush(pVM->pStack,c) +#define POPPTR() stackPopPtr(pVM->pStack) +#define POPUNS() stackPopUNS(pVM->pStack) +#define POPINT() stackPopINT(pVM->pStack) +#define POPFLOAT() stackPopFloat(pVM->fStack) +#define POP() stackPop(pVM->pStack) +#define GETTOP() stackGetTop(pVM->pStack) +#define SETTOP(c) stackSetTop(pVM->pStack,LVALUEtoCELL(c)) +#define GETTOPF() stackGetTop(pVM->fStack) +#define SETTOPF(c) stackSetTop(pVM->fStack,LVALUEtoCELL(c)) +#define STORE(n,c) stackStore(pVM->pStack,n,LVALUEtoCELL(c)) +#define DEPTH() stackDepth(pVM->pStack) +#define DROP(n) stackDrop(pVM->pStack,n) +#define DROPF(n) stackDrop(pVM->fStack,n) +#define FETCH(n) stackFetch(pVM->pStack,n) +#define PICK(n) stackPick(pVM->pStack,n) +#define PICKF(n) stackPick(pVM->fStack,n) +#define ROLL(n) stackRoll(pVM->pStack,n) +#define ROLLF(n) stackRoll(pVM->fStack,n) + /* ** The virtual machine (VM) contains the state for one interpreter. ** Defined operations include: @@ -409,7 +462,7 @@ typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline); ** ANS Forth requires that a word's name contain {1..31} characters. */ #if !defined nFICLNAME -#define nFICLNAME 31 +#define nFICLNAME 31 #endif /* @@ -417,6 +470,7 @@ typedef void (*OUTFUNC)(struct vm *pVM, char *text, int fNewline); */ typedef struct vm { + FICL_SYSTEM *pSys; /* Which system this VM belongs to */ struct vm *link; /* Ficl keeps a VM list for simple teardown */ jmp_buf *pState; /* crude exception mechanism... */ OUTFUNC textOut; /* Output callback - see sysdep.c */ @@ -429,6 +483,9 @@ typedef struct vm FICL_UNS base; /* number conversion base */ FICL_STACK *pStack; /* param stack */ FICL_STACK *rStack; /* return stack */ +#if FICL_WANT_FLOAT + FICL_STACK *fStack; /* float stack (optional) */ +#endif CELL sourceID; /* -1 if string, 0 if normal input */ TIB tib; /* address of incoming text string */ #if FICL_WANT_USER @@ -489,7 +546,6 @@ int wordIsCompileOnly(FICL_WORD *pFW); #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 @@ -503,6 +559,7 @@ int wordIsCompileOnly(FICL_WORD *pFW); #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_BREAK -261 /* debugger breakpoint */ #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 */ @@ -561,6 +618,9 @@ void vmInnerLoop(FICL_VM *pVM); ** a word's stack effect comment. */ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells); +#if FICL_WANT_FLOAT +void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells); +#endif /* ** TIB access routines... @@ -577,6 +637,7 @@ 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 vmGetTibIndex(pVM) (pVM)->tib.index #define vmSetTibIndex(pVM, i) (pVM)->tib.index = i #define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp @@ -600,7 +661,7 @@ 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); +int strincmp(char *cp1, char *cp2, FICL_UNS count); #if defined(_WIN32) && !FICL_MAIN #pragma warning(default: 4273) @@ -614,13 +675,14 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count); ** 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! */ +#define HASHSIZE 241 /* performance, use a prime number! */ #endif typedef struct ficl_hash { - struct ficl_hash *link; /* eventual inheritance support */ - unsigned size; + struct ficl_hash *link; /* link to parent class wordlist for OO */ + char *name; /* optional pointer to \0 terminated wordlist name */ + unsigned size; /* number of buckets in the hash */ FICL_WORD *table[1]; } FICL_HASH; @@ -696,6 +758,7 @@ 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); +FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets); void dictDelete(FICL_DICT *pDict); void dictEmpty(FICL_DICT *pDict, unsigned nHash); int dictIncludes(FICL_DICT *pDict, void *p); @@ -710,6 +773,67 @@ void dictUnsmudge(FICL_DICT *pDict); CELL *dictWhere(FICL_DICT *pDict); +/* +** P A R S E S T E P +** (New for 2.05) +** See words.c: interpWord +** By default, ficl goes through two attempts to parse each token from its input +** stream: it first attempts to match it with a word in the dictionary, and +** if that fails, it attempts to convert it into a number. This mechanism is now +** extensible by additional steps. This allows extensions like floating point and +** double number support to be factored cleanly. +** +** Each parse step is a function that receives the next input token as a STRINGINFO. +** If the parse step matches the token, it must apply semantics to the token appropriate +** to the present value of VM.state (compiling or interpreting), and return FICL_TRUE. +** Otherwise it returns FICL_FALSE. See words.c: isNumber for an example +** +** Note: for the sake of efficiency, it's a good idea both to limit the number +** of parse steps and to code each parse step so that it rejects tokens that +** do not match as quickly as possible. +*/ + +typedef int (*FICL_PARSE_STEP)(FICL_VM *pVM, STRINGINFO si); + +/* +** Appends a parse step function to the end of the parse list (see +** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful, +** nonzero if there's no more room in the list. Each parse step is a word in +** the dictionary. Precompiled parse steps can use (PARSE-STEP) as their +** CFA - see parenParseStep in words.c. +*/ +int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW); /* ficl.c */ +void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep); +void ficlListParseSteps(FICL_VM *pVM); + +/* +** F I C L _ S Y S T E M +** The top level data structure of the system - ficl_system ties a list of +** virtual machines with their corresponding dictionaries. Ficl 3.0 will +** support multiple Ficl systems, allowing multiple concurrent sessions +** to separate dictionaries with some constraints. +** The present model allows multiple sessions to one dictionary provided +** you implement ficlLockDictionary() as specified in sysdep.h +** +** RESTRICTIONS: due to the use of static variables in words.c for compiling +** comtrol structures faster, if you use multiple ficl systems these variables +** will point into the most recently initialized dictionary - this is probably +** not a problem provided the precompiled dictionaries are identical for +** all systems. +*/ +struct ficl_system +{ + FICL_SYSTEM *link; + FICL_WORD *parseList[FICL_MAX_PARSE_STEPS]; + FICL_VM *vmList; + FICL_DICT *dp; + FICL_DICT *envp; +#ifdef FICL_WANT_LOCALS + FICL_DICT *localp; +#endif + FICL_WORD *pInterp[3]; +}; + /* ** External interface to FICL... */ @@ -835,27 +959,60 @@ int ficlBuild(char *name, FICL_CODE code, char flags); ** 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); +void ficlCompileCore(FICL_SYSTEM *pSys); +void ficlCompilePrefix(FICL_SYSTEM *pSys); +void ficlCompileSearch(FICL_SYSTEM *pSys); +void ficlCompileSoftCore(FICL_SYSTEM *pSys); +void ficlCompileTools(FICL_SYSTEM *pSys); +#if FICL_WANT_FLOAT +void ficlCompileFloat(FICL_SYSTEM *pSys); +#endif +#if FICL_PLATFORM_EXTEND +void ficlCompilePlatform(FICL_SYSTEM *pSys); +#endif /* ** from words.c... */ void constantParen(FICL_VM *pVM); void twoConstParen(FICL_VM *pVM); +int ficlParseNumber(FICL_VM *pVM, STRINGINFO si); +void ficlTick(FICL_VM *pVM); +void parseStepParen(FICL_VM *pVM); /* -** Dictionary on-demand resizing +** From tools.c */ -extern unsigned int dictThreshold; -extern unsigned int dictIncrease; +int isAFiclWord(FICL_WORD *pFW); + +/* +** The following supports SEE and the debugger. +*/ +typedef enum +{ + BRANCH, + COLON, + CONSTANT, + CREATE, + DO, + DOES, + IF, + LITERAL, + LOOP, + PLOOP, + PRIMITIVE, + QDO, + STRINGLIT, + USER, + VARIABLE, +} WORDKIND; +WORDKIND ficlWordClassify(FICL_WORD *pFW); /* -** So we can more easily debug... +** Dictionary on-demand resizing */ -#ifdef FICL_TRACE -extern int ficl_trace; -#endif +extern unsigned int dictThreshold; +extern unsigned int dictIncrease; /* ** Various FreeBSD goodies diff --git a/sys/boot/ficl/ficlstring.c b/sys/boot/ficl/ficlstring.c new file mode 100644 index 0000000..aa09173 --- /dev/null +++ b/sys/boot/ficl/ficlstring.c @@ -0,0 +1,29 @@ +/******************************************************************* +** f i c l s t r i n g . c +** Forth Inspired Command Language +** ANS STRING words plus ficl extras for c-string class +** Author: John Sadler (john_sadler@alum.mit.edu) +** Created: 2 June 2000 +** +*******************************************************************/ + +/* $FreeBSD$ */ + +#ifdef TESTMAIN +#include <ctype.h> +#else +#include <stand.h> +#endif +#include <string.h> +#include "ficl.h" + + +/************************************************************************** + f o r m a t +** ( params... fmt-addr fmt-u dest-addr dest-u -- dest-addr dest-u ) +**************************************************************************/ + +void ficlStrFormat(FICL_VM *pVM) +{ + return; +} diff --git a/sys/boot/ficl/i386/sysdep.h b/sys/boot/ficl/i386/sysdep.h index 99ccd58..b44fbc4 100644 --- a/sys/boot/ficl/i386/sysdep.h +++ b/sys/boot/ficl/i386/sysdep.h @@ -9,27 +9,43 @@ ** FICL_ROBUST is enabled. This may require some consideration ** in firmware systems since assert often ** assumes stderr/stdout. -** +** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ *******************************************************************/ /* -** 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 not supported. -** -** 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. +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R ** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** ** 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. +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ @@ -41,14 +57,12 @@ #include <stddef.h> /* size_t, NULL */ #include <setjmp.h> - #include <assert.h> #if !defined IGNORE /* Macro to silence unused param warnings */ #define IGNORE(x) &x #endif - /* ** TRUE and FALSE for C boolean operations, and ** portable 32 bit types for CELLs @@ -89,6 +103,7 @@ ** FICL_UNS and FICL_INT must have the same size as a void* on ** the target system. A CELL is a union of void*, FICL_UNS, and ** FICL_INT. +** (11/2000: same for FICL_FLOAT) */ #if !defined FICL_INT #define FICL_INT INT32 @@ -98,6 +113,10 @@ #define FICL_UNS UNS32 #endif +#if !defined FICL_FLOAT +#define FICL_FLOAT float +#endif + /* ** Ficl presently supports values of 32 and 64 for BITS_PER_CELL */ @@ -135,9 +154,108 @@ typedef struct /* -** Build controls +** B U I L D C O N T R O L S +*/ + +#if !defined (FICL_MINIMAL) +#define FICL_MINIMAL 0 +#endif +#if (FICL_MINIMAL) +#define FICL_WANT_SOFTWORDS 0 +#define FICL_WANT_FLOAT 0 +#define FICL_WANT_USER 0 +#define FICL_WANT_LOCALS 0 +#define FICL_WANT_DEBUGGER 0 +#define FICL_WANT_OOP 0 +#define FICL_PLATFORM_EXTEND 0 +#define FICL_MULTITHREAD 0 +#define FICL_ROBUST 0 +#define FICL_EXTENDED_PREFIX 0 +#endif + +/* +** FICL_PLATFORM_EXTEND +** Includes words defined in ficlCompilePlatform +*/ +#if !defined (FICL_PLATFORM_EXTEND) +#define FICL_PLATFORM_EXTEND 1 +#endif + +/* +** FICL_WANT_FLOAT +** Includes a floating point stack for the VM, and words to do float operations. +** Contributed by Guy Carver +*/ +#if !defined (FICL_WANT_FLOAT) +#define FICL_WANT_FLOAT 0 +#endif + +/* +** FICL_WANT_DEBUGGER +** Inludes a simple source level debugger +*/ +#if !defined (FICL_WANT_DEBUGGER) +#define FICL_WANT_DEBUGGER 1 +#endif + +/* +** User variables: per-instance variables bound to the VM. +** Kinda like thread-local storage. Could be implemented in a +** VM private dictionary, but I've chosen the lower overhead +** approach of an array of CELLs instead. +*/ +#if !defined FICL_WANT_USER +#define FICL_WANT_USER 1 +#endif + +#if !defined FICL_USER_CELLS +#define FICL_USER_CELLS 16 +#endif + +/* +** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and +** a private dictionary for local variable compilation. +*/ +#if !defined FICL_WANT_LOCALS +#define FICL_WANT_LOCALS 1 +#endif + +/* Max number of local variables per definition */ +#if !defined FICL_MAX_LOCALS +#define FICL_MAX_LOCALS 16 +#endif + +/* +** FICL_WANT_OOP +** Inludes object oriented programming support (in softwords) +** OOP support requires locals and user variables! +*/ +#if !(FICL_WANT_LOCALS) || !(FICL_WANT_USER) +#if !defined (FICL_WANT_OOP) +#define FICL_WANT_OOP 0 +#endif +#endif + +#if !defined (FICL_WANT_OOP) +#define FICL_WANT_OOP 1 +#endif + +/* +** FICL_WANT_SOFTWORDS +** Controls inclusion of all softwords in softcore.c +*/ +#if !defined (FICL_WANT_SOFTWORDS) +#define FICL_WANT_SOFTWORDS 1 +#endif + +/* ** FICL_MULTITHREAD enables dictionary mutual exclusion ** wia the ficlLockDictionary system dependent function. +** Note: this implementation is experimental and poorly +** tested. Further, it's unnecessary unless you really +** intend to have multiple SESSIONS (poor choice of name +** on my part) - that is, threads that modify the dictionary +** at the same time. */ #if !defined FICL_MULTITHREAD #define FICL_MULTITHREAD 0 @@ -152,7 +270,6 @@ typedef struct #define PORTABLE_LONGMULDIV 0 #endif - /* ** INLINE_INNER_LOOP causes the inner interpreter to be inline code ** instead of a function call. This is mainly because MS VC++ 5 @@ -214,30 +331,21 @@ typedef struct #endif /* -** User variables: per-instance variables bound to the VM. -** Kinda like thread-local storage. Could be implemented in a -** VM private dictionary, but I've chosen the lower overhead -** approach of an array of CELLs instead. +** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure +** that stores pointers to parser extension functions. I would never expect to have +** more than 8 of these, so that's the default limit. Too many of these functions +** will probably exact a nasty performance penalty. */ -#if !defined FICL_WANT_USER -#define FICL_WANT_USER 1 -#endif - -#if !defined FICL_USER_CELLS -#define FICL_USER_CELLS 16 +#if !defined FICL_MAX_PARSE_STEPS +#define FICL_MAX_PARSE_STEPS 8 #endif -/* -** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and -** a private dictionary for local variable compilation. +/* +** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if +** included as part of softcore.c) */ -#if !defined FICL_WANT_LOCALS -#define FICL_WANT_LOCALS 1 -#endif - -/* Max number of local variables per definition */ -#if !defined FICL_MAX_LOCALS -#define FICL_MAX_LOCALS 16 +#if !defined FICL_EXTENDED_PREFIX +#define FICL_EXTENDED_PREFIX 0 #endif /* diff --git a/sys/boot/ficl/loader.c b/sys/boot/ficl/loader.c index 5f32134..f4a6ad4 100644 --- a/sys/boot/ficl/loader.c +++ b/sys/boot/ficl/loader.c @@ -37,7 +37,7 @@ #include <string.h> #include "ficl.h" -/* FreeBSD's loader interaction words +/* FreeBSD's loader interaction words and extras * * setenv ( value n name n' -- ) * setenv? ( value n name n' flag -- ) @@ -49,8 +49,10 @@ * pnpdevices ( -- addr ) * pnphandlers ( -- addr ) * ccall ( [[...[p10] p9] ... p1] n addr -- result ) + * .# ( value -- ) */ +#ifndef TESTMAIN void ficlSetenv(FICL_VM *pVM) { @@ -276,6 +278,8 @@ ficlPnphandlers(FICL_VM *pVM) #endif +#endif /* ndef TESTMAIN */ + void ficlCcall(FICL_VM *pVM) { @@ -305,3 +309,300 @@ ficlCcall(FICL_VM *pVM) return; } +/************************************************************************** + 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 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 == -1 to flush + ** any pending REFILLs (as required by FILE wordset) + */ + pVM->sourceID.i = -1; + ficlExec(pVM, ""); + + pVM->sourceID = id; + return rval; +} + +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; +} + +/* 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; +} + +/* +** Retrieves free space remaining on the dictionary +*/ + +static void freeHeap(FICL_VM *pVM) +{ + stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict())); +} + + +/******************* 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); +} + + +/************************************************************************** + f i c l C o m p i l e P l a t f o r m +** Build FreeBSD platform extensions into the system dictionary +**************************************************************************/ +void ficlCompilePlatform(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + assert (dp); + + dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT); + 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); + +#ifndef TESTMAIN +#ifdef __i386__ + dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT); + dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT); +#endif + dictAppendWord(dp, "setenv", ficlSetenv, FW_DEFAULT); + dictAppendWord(dp, "setenv?", ficlSetenvq, FW_DEFAULT); + dictAppendWord(dp, "getenv", ficlGetenv, FW_DEFAULT); + dictAppendWord(dp, "unsetenv", ficlUnsetenv, FW_DEFAULT); + dictAppendWord(dp, "copyin", ficlCopyin, FW_DEFAULT); + dictAppendWord(dp, "copyout", ficlCopyout, FW_DEFAULT); + dictAppendWord(dp, "findfile", ficlFindfile, FW_DEFAULT); +#ifdef HAVE_PNP + dictAppendWord(dp, "pnpdevices",ficlPnpdevices, FW_DEFAULT); + dictAppendWord(dp, "pnphandlers",ficlPnphandlers, FW_DEFAULT); +#endif + dictAppendWord(dp, "ccall", ficlCcall, FW_DEFAULT); +#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 + + return; +} + diff --git a/sys/boot/ficl/math64.c b/sys/boot/ficl/math64.c index e3d64e8..a355883 100644 --- a/sys/boot/ficl/math64.c +++ b/sys/boot/ficl/math64.c @@ -5,7 +5,44 @@ ** Created: 25 January 1998 ** Rev 2.03: Support for 128 bit DP math. This file really ouught to ** be renamed! +** $Id: math64.c,v 1.5 2001-04-26 21:41:36-07 jsadler Exp jsadler $ *******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: math64.c,v 1.5 2001-04-26 21:41:36-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -311,7 +348,7 @@ UNS16 m64UMod(DPUNS *pUD, UNS16 base) /************************************************************************** ** Contributed by -** Michael A. Gauland gaulandm@mdhost.cse.tek.com +** Michael A. Gauland gaulandm@mdhost.cse.tek.com **************************************************************************/ #if PORTABLE_LONGMULDIV != 0 /************************************************************************** @@ -454,7 +491,7 @@ int m64Compare(DPUNS x, DPUNS y) f i c l L o n g M u l ** Portable versions of ficlLongMul and ficlLongDiv in C ** Contributed by: -** Michael A. Gauland gaulandm@mdhost.cse.tek.com +** Michael A. Gauland gaulandm@mdhost.cse.tek.com **************************************************************************/ DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) { @@ -481,7 +518,7 @@ DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) f i c l L o n g D i v ** Portable versions of ficlLongMul and ficlLongDiv in C ** Contributed by: -** Michael A. Gauland gaulandm@mdhost.cse.tek.com +** Michael A. Gauland gaulandm@mdhost.cse.tek.com **************************************************************************/ UNSQR ficlLongDiv(DPUNS q, FICL_UNS y) { diff --git a/sys/boot/ficl/math64.h b/sys/boot/ficl/math64.h index a98af9ab..8fd1517 100644 --- a/sys/boot/ficl/math64.h +++ b/sys/boot/ficl/math64.h @@ -3,31 +3,43 @@ ** Forth Inspired Command Language - 64 bit math support routines ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 25 January 1998 -** +** $Id: math64.h,v 1.5 2001-04-26 21:41:53-07 jsadler Exp jsadler $ *******************************************************************/ /* -** 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 not supported. -** -** 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. +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R ** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** ** 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. -** -** NOTE: this file depends on sysdep.h for the definition -** of PORTABLE_LONGMULDIV and several abstract types. +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. ** +** $Id: math64.h,v 1.5 2001-04-26 21:41:53-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ diff --git a/sys/boot/ficl/prefix.c b/sys/boot/ficl/prefix.c new file mode 100644 index 0000000..0d52b7c --- /dev/null +++ b/sys/boot/ficl/prefix.c @@ -0,0 +1,191 @@ +/******************************************************************* +** p r e f i x . c +** Forth Inspired Command Language +** Parser extensions for Ficl +** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu) +** Created: April 2001 +** $Id: prefix.c,v 1.1 2001-04-26 21:41:33-07 jsadler Exp jsadler $ +*******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: prefix.c,v 1.1 2001-04-26 21:41:33-07 jsadler Exp jsadler $ +*/ + +/* $FreeBSD$ */ + +#include <string.h> +#include <ctype.h> +#include "ficl.h" +#include "math64.h" + +/* +** (jws) revisions: +** A prefix is a word in a dedicated wordlist (name stored in list_name below) +** that is searched in a special way by the prefix parse step. When a prefix +** matches the beginning of an incoming token, push the non-prefix part of the +** token back onto the input stream and execute the prefix code. +** +** The parse step is called ficlParsePrefix. +** Storing prefix entries in the dictionary greatly simplifies +** the process of matching and dispatching prefixes, avoids the +** need to clean up a dynamically allocated prefix list when the system +** goes away, but still allows prefixes to be allocated at runtime. +*/ + +static char list_name[] = "<prefixes>"; + +/************************************************************************** + f i c l P a r s e P r e f i x +** This is the parse step for prefixes - it checks an incoming word +** to see if it starts with a prefix, and if so runs the corrseponding +** code against the remainder of the word and returns true. +**************************************************************************/ +int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si) +{ + int i; + FICL_HASH *pHash; + FICL_WORD *pFW = ficlLookup(list_name); + + assert(pFW); + pHash = (FICL_HASH *)(pFW->param[0].p); + /* + ** Walk the list looking for a match with the beginning of the incoming token + */ + for (i = 0; i < (int)pHash->size; i++) + { + pFW = pHash->table[i]; + while (pFW != NULL) + { + int n; + n = pFW->nName; + /* + ** If we find a match, adjust the TIB to give back the non-prefix characters + ** and execute the prefix word. + */ + if (!strincmp(SI_PTR(si), pFW->name, (FICL_UNS)n)) + { + vmSetTibIndex(pVM, vmGetTibIndex(pVM) - 1 - SI_COUNT(si) + n); + vmExecute(pVM, pFW); + + return FICL_TRUE; + } + pFW = pFW->link; + } + } + + return FICL_FALSE; +} + + +static void tempBase(FICL_VM *pVM, int base) +{ + int oldbase = pVM->base; + STRINGINFO si = vmGetWord0(pVM); + + pVM->base = base; + if (!ficlParseNumber(pVM, si)) + { + int i = SI_COUNT(si); + vmThrowErr(pVM, "0x%.*s is not a valid hex value", i, SI_PTR(si)); + } + + pVM->base = oldbase; + return; +} + +static void fTempBase(FICL_VM *pVM) +{ + int base = stackPopINT(pVM->pStack); + tempBase(pVM, base); + return; +} + +static void prefixHex(FICL_VM *pVM) +{ + tempBase(pVM, 16); +} + +static void prefixTen(FICL_VM *pVM) +{ + tempBase(pVM, 10); +} + + +/************************************************************************** + f i c l C o m p i l e P r e f i x +** Build prefix support into the dictionary and the parser +** Note: since prefixes always execute, they are effectively IMMEDIATE. +** If they need to generate code in compile state you must add +** this code explicitly. +**************************************************************************/ +void ficlCompilePrefix(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + FICL_HASH *pHash; + FICL_HASH *pPrevCompile = dp->pCompile; +#if (FICL_EXTENDED_PREFIX) + FICL_WORD *pFW; +#endif + + /* + ** Create a named wordlist for prefixes to reside in... + ** Since we're doing a special kind of search, make it + ** a single bucket hashtable - hashing does not help here. + */ + pHash = dictCreateWordlist(dp, 1); + pHash->name = list_name; + dictAppendWord(dp, list_name, constantParen, FW_DEFAULT); + dictAppendCell(dp, LVALUEtoCELL(pHash)); + dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT); + + /* + ** Temporarily make the prefix list the compile wordlist so that + ** we can create some precompiled prefixes. + */ + dp->pCompile = pHash; + dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT); + dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT); +#if (FICL_EXTENDED_PREFIX) + pFW = ficlLookup("\\"); + if (pFW) + { + dictAppendWord(dp, "//", pFW->code, FW_DEFAULT); + } +#endif + dp->pCompile = pPrevCompile; + + ficlAddPrecompiledParseStep(pSys, "prefix?", ficlParsePrefix); + return; +} diff --git a/sys/boot/ficl/search.c b/sys/boot/ficl/search.c new file mode 100644 index 0000000..36844ea --- /dev/null +++ b/sys/boot/ficl/search.c @@ -0,0 +1,395 @@ +/******************************************************************* +** s e a r c h . c +** Forth Inspired Command Language +** ANS Forth SEARCH and SEARCH-EXT word-set written in C +** Author: John Sadler (john_sadler@alum.mit.edu) +** Created: 6 June 2000 +** $Id: search.c,v 1.4 2001-04-26 21:41:31-07 jsadler Exp jsadler $ +*******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: search.c,v 1.4 2001-04-26 21:41:31-07 jsadler Exp jsadler $ +*/ + +/* $FreeBSD$ */ + +#include <string.h> +#include "ficl.h" +#include "math64.h" + +/************************************************************************** + 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; +} + + +/************************************************************************** + f i c l - 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 ficlWordlist(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); + pHash = dictCreateWordlist(dp, nBuckets); + 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; +} + + +/************************************************************************** + W I D - G E T - N A M E +** ficl ( wid -- c-addr u ) +** Get wid's (optional) name and push onto stack as a counted string +**************************************************************************/ +static void widGetName(FICL_VM *pVM) +{ + FICL_HASH *pHash = vmPop(pVM).p; + char *cp = pHash->name; + int len = 0; + + if (cp) + len = strlen(cp); + + vmPush(pVM, LVALUEtoCELL(cp)); + vmPush(pVM, LVALUEtoCELL(len)); + return; +} + +/************************************************************************** + W I D - S E T - N A M E +** ficl ( wid c-addr -- ) +** Set wid's name pointer to the \0 terminated string address supplied +**************************************************************************/ +static void widSetName(FICL_VM *pVM) +{ + char *cp = (char *)vmPop(pVM).p; + FICL_HASH *pHash = vmPop(pVM).p; + pHash->name = cp; + return; +} + + +/************************************************************************** + 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; +} + + +/************************************************************************** + f i c l C o m p i l e S e a r c h +** Builds the primitive wordset and the environment-query namespace. +**************************************************************************/ + +void ficlCompileSearch(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + assert (dp); + + /* + ** 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", + ficlWordlist, FW_DEFAULT); + + /* + ** Set SEARCH environment query values + */ + ficlSetEnv("search-order", FICL_TRUE); + ficlSetEnv("search-order-ext", FICL_TRUE); + ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); + + dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT); + dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT); + dictAppendWord(dp, "wid-set-super", + setParentWid, FW_DEFAULT); + return; +} + diff --git a/sys/boot/ficl/softwords/classes.fr b/sys/boot/ficl/softwords/classes.fr index 3d233e4..b56da37 100644 --- a/sys/boot/ficl/softwords/classes.fr +++ b/sys/boot/ficl/softwords/classes.fr @@ -1,3 +1,4 @@ +\ #if (FICL_WANT_OOP) \ ** ficl/softwords/classes.fr \ ** F I C L 2 . 0 C L A S S E S \ john sadler 1 sep 98 @@ -5,7 +6,6 @@ \ \ $FreeBSD$ -.( loading ficl utility classes ) cr also oop definitions \ REF subclass holds a pointer to an object. It's @@ -38,10 +38,11 @@ end-class object subclass c-4byte 4 chars: .payload - : get drop i@ ; - : set drop i! ; + : get drop q@ ; + : set drop q! ; end-class + object subclass c-cell cell: .payload @@ -104,11 +105,10 @@ object subclass c-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 + : index-ptr { index 2:this -- } + this --> get-ptr ( addr ) + this --> @size index * + ( addr' ) + this --> set-ptr ; end-class @@ -128,20 +128,19 @@ c-ptr subclass c-cellPtr end-class -\ ** C - I N T P T R -\ Models a pointer to an int (a 32 bit scalar). +\ ** C - 4 B Y T E P T R +\ Models a pointer to a quadbyte scalar c-ptr subclass c-4bytePtr : @size 2drop 4 ; \ fetch and store through the pointer : get ( inst class -- value ) - c-ptr => get-ptr i@ + c-ptr => get-ptr q@ ; : set ( value inst class -- ) - c-ptr => get-ptr i! + c-ptr => get-ptr q! ; -end-class - - + end-class + \ ** C - 2 B Y T E P T R \ Models a pointer to a 16 bit scalar c-ptr subclass c-2bytePtr @@ -171,3 +170,4 @@ end-class previous definitions +\ #endif diff --git a/sys/boot/ficl/softwords/ifbrack.fr b/sys/boot/ficl/softwords/ifbrack.fr index 6716e93..2359e94 100644 --- a/sys/boot/ficl/softwords/ifbrack.fr +++ b/sys/boot/ficl/softwords/ifbrack.fr @@ -4,7 +4,7 @@ \ $FreeBSD$ -hidden dup >search ficl-set-current +hide : ?[if] ( c-addr u -- c-addr u flag ) 2dup 2dup diff --git a/sys/boot/ficl/softwords/jhlocal.fr b/sys/boot/ficl/softwords/jhlocal.fr index 4b96c02..b6e8467 100644 --- a/sys/boot/ficl/softwords/jhlocal.fr +++ b/sys/boot/ficl/softwords/jhlocal.fr @@ -12,6 +12,8 @@ \ 3 = found } \ 4 = end of line \ +\ revised 2 June 2000 - { | a -- } now works correctly +\ \ $FreeBSD$ hide @@ -24,10 +26,20 @@ hide : ?| ( 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 ; +\ examine name - if it's a 2local (starts with "2:"), +\ nibble the prefix (the "2:") off the name and push true. +\ Otherwise push false +\ Problem if the local is named "2:" - we fall off the end... +: ?2loc ( c-addr u -- c-addr u flag ) + over dup c@ [char] 2 = + swap 1+ c@ [char] : = and + if + 2 - swap char+ char+ swap \ dcs/jws: nibble the '2:' + true + else + false + endif +; : ?delim ( c-addr u -- state | c-addr u 0 ) ?| if 2drop 1 exit endif diff --git a/sys/boot/ficl/softwords/oo.fr b/sys/boot/ficl/softwords/oo.fr index 65ddf33..87ab576 100644 --- a/sys/boot/ficl/softwords/oo.fr +++ b/sys/boot/ficl/softwords/oo.fr @@ -1,12 +1,11 @@ +\ #if FICL_WANT_OOP \ ** 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 +17 ficl-vocabulary oop also oop definitions \ Design goals: @@ -58,33 +57,38 @@ user current-class \ parse-method compiles the method name so that it pushes \ the string base address and count at run-time. \ + +hide + : 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 ) +: lookup-method { class 2:name -- class xt } + name class cell+ @ ( c-addr u wid ) + search-wordlist ( 0 | xt 1 | xt -1 ) 0= if - c-addr u type ." not found in " - body> >name type + name type ." not found in " + class body> >name type cr abort - endif -; - -: exec-method ( instance class c-addr u -- <method-signature> ) - lookup-method execute + endif + class swap ; : find-method-xt \ name ( class -- class xt ) parse-word lookup-method ; +set-current ( stop hiding definitions ) + +: catch-method ( instance class c-addr u -- <method-signature> exc-flag ) + lookup-method catch +; + +: exec-method ( instance class c-addr u -- <method-signature> ) + lookup-method execute +; \ Method lookup operator takes a class-addr and instance-addr \ and executes the method from the class's wordlist if @@ -98,6 +102,19 @@ user current-class endif ; immediate +\ Method lookup with CATCH in case of exceptions +: c-> ( instance class -- ?? exc-flag ) + state @ 0= if + find-method-xt catch + else + parse-method postpone catch-method + endif +; immediate + +\ METHOD makes global words that do method invocations by late binding +\ in case you prefer this style (no --> in your code) +: method create does> body> >name lookup-method execute ; + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** E A R L Y B I N D I N G @@ -109,10 +126,27 @@ user current-class \ Usage \ my-class get-wid ( -- wid-of-my-class ) \ +1 ficl-named-wordlist instance-vars +instance-vars dup >search ficl-set-current + : => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method drop find-method-xt compile, drop ; immediate compile-only +: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class + current-class @ dup postpone => +; immediate compile-only + +: my=[ \ same as my=> , but binds a chain of methods + current-class @ + begin + parse-word 2dup + s" ]" compare while ( class c-addr u ) + lookup-method nip dup ( xt xt ) + compile, >body cell+ @ ( class' ) + repeat 2drop drop +; immediate compile-only + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ** I N S T A N C E V A R I A B L E S @@ -128,9 +162,6 @@ user current-class \ 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 @ + @@ -209,6 +240,11 @@ dup >search ficl-set-current search> drop \ pop struct builder wordlist ; +\ See resume-class (a metaclass method) below for usage +\ This is equivalent to end-class for now, but that will change +\ when we support vtable bindings. +: suspend-class ( old-wid addr[size] size -- ) end-class ; + set-current previous \ E N D I N S T A N C E V A R I A B L E S @@ -246,7 +282,9 @@ set-current previous 3 cells , \ instance size ficl-set-current does> dup -; execute metaclass +; execute metaclass +\ now brand OBJECT's wordlist (so that ORDER can display it by name) +metaclass drop cell+ @ brand-wordlist metaclass drop current-class ! do-do-instance @@ -265,8 +303,6 @@ create .wid ( class metaclass -- wid ) \ return wid of class 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 @ ; @@ -321,19 +357,60 @@ previous class ; +\ Create an anonymous initialized instance from the dictionary +: allot { 2:this -- 2:instance } + here ( instance-address ) + this my=> get-size allot + this drop 2dup --> init +; + +\ Create an anonymous array of initialized instances from the dictionary +: allot-array { nobj 2:this -- 2:instance } + here ( instance-address ) + this my=> get-size nobj * allot + this drop 2dup ( 2instance 2instance ) + nobj -rot --> array-init +; + \ create a proxy object with initialized payload address given : ref ( instance-addr class metaclass "name" -- ) drop create , , does> 2@ ; +\ suspend-class and resume-class help to build mutually referent classes. +\ Example: +\ object subclass c-akbar +\ suspend-class ( put akbar on hold while we define jeff ) +\ object subclass c-jeff +\ c-akbar ref: .akbar +\ ( and whatever else comprises this class ) +\ end-class ( done with c-jeff ) +\ c-akbar --> resume-class +\ c-jeff ref: .jeff +\ ( and whatever else goes in c-akbar ) +\ end-class ( done with c-akbar ) +\ +: resume-class { 2:this -- old-wid addr[size] size } + this --> .wid @ ficl-set-current ( old-wid ) + this --> .size dup @ ( old-wid addr[size] size ) + instance-vars >search +; + \ create a subclass +\ This method leaves the stack and search order ready for instance variable +\ building. Pushes the instance-vars wordlist onto the search order, +\ and sets the compilation wordlist to be the private wordlist of the +\ new class. The class's wordlist is deliberately NOT in the search order - +\ to prevent methods from getting used with wrong data. +\ Postcondition: leaves the address of the new class in current-class : 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 + wid wid-set-super \ set superclass + create immediate \ get the subclass name + wid brand-wordlist \ label the subclass wordlist here current-class ! \ prep for do-do-instance parent , \ save parent class wid , \ save wid @@ -341,7 +418,7 @@ previous metaclass => .do-instance wid ficl-set-current -rot do-do-instance - instance-vars >search \ push struct builder wordlist + instance-vars >search \ push struct builder wordlist ; \ OFFSET-OF returns the offset of an instance variable @@ -380,14 +457,14 @@ previous : see ( class meta -- ) metaclass => get-wid >search see previous ; -set-current +previous set-current \ E N D M E T A C L A S S -\ META is a nickname for the address of METACLASS... +\ ** META is a nickname for the address of METACLASS... metaclass drop constant meta -\ SUBCLASS is a nickname for a class's SUB method... +\ ** 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 ; @@ -405,9 +482,12 @@ constant meta ficl-set-current does> meta ; execute object +\ now brand OBJECT's wordlist (so that ORDER can display it by name) +object drop cell+ @ brand-wordlist object drop current-class ! do-do-instance +instance-vars >search \ O B J E C T M E T H O D S \ Convert instance cell-pair to class cell-pair @@ -491,8 +571,12 @@ do-do-instance inst swap - class ; -set-current +: debug ( 2this -- ?? ) + find-method-xt debug-xt ; + +previous set-current \ E N D O B J E C T -previous definitions +only definitions +\ #endif diff --git a/sys/boot/ficl/softwords/prefix.fr b/sys/boot/ficl/softwords/prefix.fr new file mode 100644 index 0000000..d7b79a9 --- /dev/null +++ b/sys/boot/ficl/softwords/prefix.fr @@ -0,0 +1,59 @@ +\ ** +\ ** Prefix words for ficl +\ ** submitted by Larry Hastings, larry@hastings.org +\ ** +\ (jws) To make a prefix, simply create a new definition in the <prefixes> +\ wordlist. start-prefixes and end-prefixes handle the bookkeeping + +\ $FreeBSD$ + +variable save-current + +: start-prefixes get-current save-current ! <prefixes> set-current ; +: end-prefixes save-current @ set-current ; +: show-prefixes <prefixes> >search words search> drop ; + +\ #if (FICL_EXTENDED_PREFIX) + +start-prefixes + +\ define " (double-quote) as an alias for s", and make it a prefix +: " postpone s" ; immediate + + +\ make .( a prefix (we just create an alias for it in the prefixes list) +: .( .( ; + + +\ make \ a prefix, and add // (same thing) as a prefix too +\ (jws) "//" is precompiled to save aggravation with Perl +\ : // postpone \ ; immediate + + +\ ** add 0b, 0o, 0d, and 0x as prefixes +\ ** these temporarily shift the base to 2, 8, 10, and 16 respectively +\ ** and consume the next number in the input stream, pushing/compiling +\ ** as normal + +\ (jws) __tempbase is precompiled, as are 0x and 0d - see prefix.c +\ +\ : __tempbase { newbase | oldbase -- } +\ base @ to oldbase +\ newbase base ! +\ 0 0 parse-word >number 2drop drop +\ oldbase base ! +\ ; + +: 0b 2 __tempbase ; immediate + +: 0o 8 __tempbase ; immediate + +\ : 0d 10 __tempbase ; immediate +\ "0d" add-prefix + +\ : 0x 16 __tempbase ; immediate +\ "0x" add-prefix + +end-prefixes + +\ #endif diff --git a/sys/boot/ficl/softwords/softcore.awk b/sys/boot/ficl/softwords/softcore.awk index 8bfb8bf..c41996a 100644 --- a/sys/boot/ficl/softwords/softcore.awk +++ b/sys/boot/ficl/softwords/softcore.awk @@ -128,8 +128,15 @@ END \ { if (commenting) end_comments(); printf " \"quit \";\n"; - printf "\n\nvoid ficlCompileSoftCore(FICL_VM *pVM)\n"; + printf "\n\nvoid ficlCompileSoftCore(FICL_SYSTEM *pSys)\n"; printf "{\n"; - printf " assert(ficlExec(pVM, softWords) != VM_ERREXIT);\n"; + printf " FICL_VM *pVM = pSys->vmList;\n"; + printf " int ret = sizeof (softWords);\n"; + printf " assert(pVM);\n"; + printf "\n" + printf " ret = ficlExec(pVM, softWords);\n"; + printf " if (ret == VM_ERREXIT)\n"; + printf " assert(FALSE);\n"; + printf " return;\n"; printf "}\n"; } diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr index fa4149a..17844a8 100644 --- a/sys/boot/ficl/softwords/softcore.fr +++ b/sys/boot/ficl/softwords/softcore.fr @@ -7,8 +7,8 @@ \ ** Ficl USER variables \ ** See words.c for primitive def'n of USER -\ #if FICL_WANT_USER +\ #if FICL_WANT_USER variable nUser 0 nUser ! : user \ name ( -- ) nUser dup @ user 1 swap +! ; @@ -31,33 +31,32 @@ decimal 32 constant bl : spaces ( n -- ) 0 ?do space loop ; -: abort" +: abort" state @ if postpone if - [char] " parse - postpone sliteral - postpone type + postpone ." +\ postpone type postpone cr -2 postpone literal postpone throw postpone endif else - [char] " parse + [char] " parse rot if type cr -2 throw - else - 2drop - then - then + else + 2drop + endif + endif ; immediate \ ** CORE EXT -0 constant false -false invert constant true +0 constant false +false invert constant true : <> = 0= ; : 0<> 0= 0= ; : compile, , ; @@ -98,20 +97,45 @@ false invert constant true ; \ ** SEARCH+EXT words and ficl helpers -\ +\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom: +\ wordlist dup create , brand-wordlist +\ gets the name of the word made by create and applies it to the wordlist... +: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ; + +: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid ) + ficl-wordlist dup create , brand-wordlist does> @ ; + : wordlist ( -- ) 1 ficl-wordlist ; +\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value +: ficl-set-current ( wid -- old-wid ) + get-current swap set-current ; + \ DO_VOCABULARY handles the DOES> part of a VOCABULARY \ When executed, new voc replaces top of search stack : do-vocabulary ( -- ) does> @ search> drop >search ; +: ficl-vocabulary ( nBuckets name -- ) + ficl-named-wordlist do-vocabulary ; + : vocabulary ( name -- ) - wordlist create , do-vocabulary ; + 1 ficl-vocabulary ; -: ficl-vocabulary ( nBuckets name -- ) - ficl-wordlist create , do-vocabulary ; +\ PREVIOUS drops the search order stack +: previous ( -- ) search> drop ; + +\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace +\ USAGE: +\ hide +\ <definitions to hide> +\ set-current +\ <words that use hidden defs> +\ previous ( pop HIDDEN off the search order ) + +1 ficl-named-wordlist hidden +: hide hidden dup >search ficl-set-current ; \ ALSO dups the search stack... : also ( -- ) @@ -127,20 +151,26 @@ false invert constant true -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 ; +hide +: list-wid ( wid -- ) + dup wid-get-name ( wid c-addr u ) + ?dup if + type drop + else + drop ." (unnamed wid) " x. + endif cr +; +set-current \ stop hiding words -\ PREVIOUS drops the search order stack -: previous ( -- ) search> drop ; +: order ( -- ) + ." Search:" cr + get-order 0 ?do 3 spaces list-wid loop cr + ." Compile: " get-current list-wid cr +; -\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value -: ficl-set-current ( wid -- old-wid ) - get-current swap set-current ; +: debug ' debug-xt ; -wordlist constant hidden -: hide hidden dup >search ficl-set-current ; +previous \ lose hidden words from search order \ ** E N D S O F T C O R E . F R diff --git a/sys/boot/ficl/softwords/string.fr b/sys/boot/ficl/softwords/string.fr index a78f4ea..dabb390 100644 --- a/sys/boot/ficl/softwords/string.fr +++ b/sys/boot/ficl/softwords/string.fr @@ -1,3 +1,4 @@ +\ #if (FICL_WANT_OOP) \ ** ficl/softwords/string.fr \ A useful dynamic string class \ John Sadler 14 Sep 1998 @@ -12,132 +13,131 @@ \ \ $FreeBSD$ -.( loading ficl string class ) cr also oop definitions object subclass c-string - c-4byte obj: .count - c-4byte obj: .buflen - c-ptr obj: .buf - 64 constant min-buf + c-cell obj: .count + c-cell obj: .buflen + c-ptr obj: .buf + 32 constant min-buf - : get-count ( 2this -- count ) c-string => .count c-4byte => get ; - : set-count ( count 2this -- ) c-string => .count c-4byte => set ; + : get-count ( 2:this -- count ) my=[ .count get ] ; + : set-count ( count 2:this -- ) my=[ .count set ] ; - : ?empty ( 2this -- flag ) --> get-count 0= ; + : ?empty ( 2:this -- flag ) --> get-count 0= ; - : get-buflen ( 2this -- len ) c-string => .buflen c-4byte => get ; - : set-buflen ( len 2this -- ) c-string => .buflen c-4byte => set ; + : get-buflen ( 2:this -- len ) my=[ .buflen get ] ; + : set-buflen ( len 2:this -- ) my=[ .buflen set ] ; - : get-buf ( 2this -- ptr ) c-string => .buf c-ptr => get-ptr ; - : set-buf { ptr len 2this -- } - ptr 2this c-string => .buf c-ptr => set-ptr - len 2this c-string => set-buflen + : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ; + : set-buf { ptr len 2:this -- } + ptr this my=[ .buf set-ptr ] + len this my=> set-buflen ; \ set buffer to null and buflen to zero - : clr-buf ( 2this -- ) - 0 0 2over c-string => set-buf - 0 -rot c-string => set-count + : clr-buf ( 2:this -- ) + 0 0 2over my=> set-buf + 0 -rot my=> set-count ; \ free the buffer if there is one, set buf pointer to null - : free-buf { 2this -- } - 2this c-string => get-buf - ?dup if - free - abort" c-string free failed" - 2this c-string => clr-buf + : free-buf { 2:this -- } + this my=> get-buf + ?dup if + free + abort" c-string free failed" + this my=> clr-buf endif ; \ guarantee buffer is large enough to hold size chars - : size-buf { size 2this -- } + : size-buf { size 2:this -- } size 0< abort" need positive size for size-buf" - size 0= if - 2this --> free-buf exit + size 0= if + this --> free-buf exit endif \ force buflen to be a positive multiple of min-buf chars - c-string => min-buf size over / 1+ * chars to size + my=> min-buf size over / 1+ * chars to size \ if buffer is null, allocate one, else resize it - 2this --> get-buflen 0= + this --> get-buflen 0= if - size allocate + size allocate abort" out of memory" - size 2this --> set-buf - size 2this --> set-buflen + size this --> set-buf + size this --> set-buflen exit endif - size 2this --> get-buflen > if - 2this --> get-buf size resize + size this --> get-buflen > if + this --> get-buf size resize abort" out of memory" - size 2this --> set-buf + size this --> set-buf endif ; - : set { c-addr u 2this -- } - u 2this --> size-buf - u 2this --> set-count - c-addr 2this --> get-buf u move + : set { c-addr u 2:this -- } + u this --> size-buf + u this --> set-count + c-addr this --> get-buf u move ; - : get { 2this -- c-addr u } - 2this --> get-buf - 2this --> get-count + : get { 2:this -- c-addr u } + this --> get-buf + this --> get-count ; \ append string to existing one - : cat { c-addr u 2this -- } - 2this --> get-count u + dup >r - 2this --> size-buf - c-addr 2this --> get-buf 2this --> get-count + u move - r> 2this --> set-count + : cat { c-addr u 2:this -- } + this --> get-count u + dup >r + this --> size-buf + c-addr this --> get-buf this --> get-count + u move + r> this --> set-count ; - : type { 2this -- } - 2this --> ?empty if ." (empty) " exit endif - 2this --> .buf --> get-ptr - 2this --> .count --> get - type + : type { 2:this -- } + this --> ?empty if ." (empty) " exit endif + this --> .buf --> get-ptr + this --> .count --> get + type ; - : compare ( 2string 2this -- n ) - c-string => get - 2swap - c-string => get + : compare ( 2string 2:this -- n ) + --> get + 2swap + --> get 2swap compare ; - : hashcode ( 2this -- hashcode ) - c-string => get hash + : hashcode ( 2:this -- hashcode ) + --> get hash ; - \ destructor method (overrides object --> free) - : free ( 2this -- ) 2dup c-string => free-buf object => free ; + \ destructor method (overrides object --> free) + : free ( 2:this -- ) 2dup --> free-buf object => free ; end-class c-string subclass c-hashstring c-2byte obj: .hashcode - : set-hashcode { 2this -- } - 2this --> super --> hashcode - 2this --> .hashcode --> set + : set-hashcode { 2:this -- } + this --> super --> hashcode + this --> .hashcode --> set ; - : get-hashcode ( 2this -- hashcode ) + : get-hashcode ( 2:this -- hashcode ) --> .hashcode --> get ; - : set ( c-addr u 2this -- ) + : set ( c-addr u 2:this -- ) 2swap 2over --> super --> set --> set-hashcode ; - : cat ( c-addr u 2this -- ) + : cat ( c-addr u 2:this -- ) 2swap 2over --> super --> cat --> set-hashcode ; @@ -145,4 +145,4 @@ c-string subclass c-hashstring end-class previous definitions - +\ #endif diff --git a/sys/boot/ficl/stack.c b/sys/boot/ficl/stack.c index 059137c..ab0ab46 100644 --- a/sys/boot/ficl/stack.c +++ b/sys/boot/ficl/stack.c @@ -3,8 +3,44 @@ ** Forth Inspired Command Language ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 16 Oct 1997 -** +** $Id: stack.c,v 1.5 2001-04-26 21:41:29-07 jsadler Exp jsadler $ *******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: stack.c,v 1.5 2001-04-26 21:41:29-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -54,6 +90,24 @@ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells) return; } +#if FICL_WANT_FLOAT +void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells) +{ + FICL_STACK *fStack = pVM->fStack; + int nFree = fStack->base + fStack->nCells - fStack->sp; + + if (popCells > STKDEPTH(fStack)) + { + vmThrowErr(pVM, "Error: float stack underflow"); + } + + if (nFree < pushCells - popCells) + { + vmThrowErr(pVM, "Error: float stack overflow"); + } +} +#endif + /******************************************************************* s t a c k C r e a t e ** @@ -212,6 +266,12 @@ FICL_INT stackPopINT(FICL_STACK *pStack) return (*--pStack->sp).i; } +#if (FICL_WANT_FLOAT) +float stackPopFloat(FICL_STACK *pStack) +{ + return (*(--pStack->sp)).f; +} +#endif /******************************************************************* s t a c k P u s h @@ -238,6 +298,13 @@ void stackPushINT(FICL_STACK *pStack, FICL_INT i) *pStack->sp++ = LVALUEtoCELL(i); } +#if (FICL_WANT_FLOAT) +void stackPushFloat(FICL_STACK *pStack, float f) +{ + *pStack->sp++ = LVALUEtoCELL(f); +} +#endif + /******************************************************************* s t a c k R e s e t ** diff --git a/sys/boot/ficl/testmain.c b/sys/boot/ficl/testmain.c index 75e1d88..cd4da7e 100644 --- a/sys/boot/ficl/testmain.c +++ b/sys/boot/ficl/testmain.c @@ -1,6 +1,6 @@ /* -** stub main for testing FICL -** +** stub main for testing FICL under Win32 +** $Id: testmain.c,v 1.6 2000-06-17 07:43:50-07 jsadler Exp jsadler $ */ /* $FreeBSD$ */ diff --git a/sys/boot/ficl/tools.c b/sys/boot/ficl/tools.c new file mode 100644 index 0000000..0fc1a88 --- /dev/null +++ b/sys/boot/ficl/tools.c @@ -0,0 +1,800 @@ +/******************************************************************* +** t o o l s . c +** Forth Inspired Command Language - programming tools +** Author: John Sadler (john_sadler@alum.mit.edu) +** Created: 20 June 2000 +** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $ +*******************************************************************/ +/* +** NOTES: +** SEE needs information about the addresses of functions that +** are the CFAs of colon definitions, constants, variables, DOES> +** words, and so on. It gets this information from a table and supporting +** functions in words.c. +** colonParen doDoes createParen variableParen userParen constantParen +** +** Step and break debugger for Ficl +** debug ( xt -- ) Start debugging an xt +** Set a breakpoint +** Specify breakpoint default action +*/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: tools.c,v 1.4 2001-04-26 21:41:24-07 jsadler Exp jsadler $ +*/ + +/* $FreeBSD$ */ + +#ifdef TESTMAIN +#include <stdlib.h> +#include <stdio.h> /* sprintf */ +#include <ctype.h> +#else +#include <stand.h> +#endif +#include <string.h> +#include "ficl.h" + + +#if 0 +/* +** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved +** for the STEP command. The rest are user programmable. +*/ +#define nBREAKPOINTS 32 +#endif + +/* +** BREAKPOINT record. +** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt +** that the breakpoint overwrote. This is restored to the dictionary when the +** BP executes or gets cleared +** address - the location of the breakpoint (address of the instruction that +** has been replaced with the breakpoint trap +** origXT - The original contents of the location with the breakpoint +** Note: address is NULL when this breakpoint is empty +*/ +typedef struct breakpoint +{ + void *address; + FICL_WORD *origXT; +} BREAKPOINT; + +static BREAKPOINT bpStep = {NULL, NULL}; + +/* +** vmSetBreak - set a breakpoint at the current value of IP by +** storing that address in a BREAKPOINT record +*/ +static void vmSetBreak(FICL_VM *pVM, BREAKPOINT *pBP) +{ + FICL_WORD *pStep = ficlLookup("step-break"); + assert(pStep); + pBP->address = pVM->ip; + pBP->origXT = *pVM->ip; + *pVM->ip = pStep; +} + + +/* +** 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! +*/ +int isAFiclWord(FICL_WORD *pFW) +{ + 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')); +} + + +static int isPrimitive(FICL_WORD *pFW) +{ + WORDKIND wk = ficlWordClassify(pFW); + return ((wk != COLON) && (wk != DOES)); +} + + +/************************************************************************** + s e e +** TOOLS ( "<spaces>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. +**************************************************************************/ +/* +** 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) +{ + static FICL_WORD *pSemiParen = NULL; + + if (!pSemiParen) + pSemiParen = ficlLookup("(;)"); + assert(pSemiParen); + + for (; pc->p != pSemiParen; pc++) + { + FICL_WORD *pFW = (FICL_WORD *)(pc->p); + + if (isAFiclWord(pFW)) + { + WORDKIND kind = ficlWordClassify(pFW); + CELL c; + + switch (kind) + { + case LITERAL: + c = *++pc; + if (isAFiclWord(c.p)) + { + FICL_WORD *pLit = (FICL_WORD *)c.p; + sprintf(pVM->pad, " literal %.*s (%#lx)", + pLit->nName, pLit->name, c.u); + } + else + sprintf(pVM->pad, " literal %ld (%#lx)", c.i, c.u); + break; + case 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); + } + break; + case IF: + 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); + break; + case BRANCH: + 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); + break; + + case QDO: + c = *++pc; + sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); + break; + case DO: + c = *++pc; + sprintf(pVM->pad, " do (leave abs %#lx)", c.u); + break; + case LOOP: + c = *++pc; + sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); + break; + case PLOOP: + c = *++pc; + sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); + break; + default: + sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); + break; + } + + 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 seeXT(FICL_VM *pVM) +{ + FICL_WORD *pFW; + WORDKIND kind; + + pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); + kind = ficlWordClassify(pFW); + + switch (kind) + { + case COLON: + sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); + vmTextOut(pVM, pVM->pad, 1); + seeColon(pVM, pFW->param); + break; + + case DOES: + vmTextOut(pVM, "does>", 1); + seeColon(pVM, (CELL *)pFW->param->p); + break; + + case CREATE: + vmTextOut(pVM, "create", 1); + break; + + case VARIABLE: + sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u); + vmTextOut(pVM, pVM->pad, 1); + break; + + case USER: + sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u); + vmTextOut(pVM, pVM->pad, 1); + break; + + case CONSTANT: + sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u); + vmTextOut(pVM, pVM->pad, 1); + + default: + vmTextOut(pVM, "primitive", 1); + break; + } + + if (pFW->flags & FW_IMMEDIATE) + { + vmTextOut(pVM, "immediate", 1); + } + + if (pFW->flags & FW_COMPILE) + { + vmTextOut(pVM, "compile-only", 1); + } + + return; +} + + +static void see(FICL_VM *pVM) +{ + ficlTick(pVM); + seeXT(pVM); + return; +} + + +/************************************************************************** + f i c l D e b u g X T +** debug ( xt -- ) +** Given an xt of a colon definition or a word defined by DOES>, set the +** VM up to debug the word: push IP, set the xt as the next thing to execute, +** set a breakpoint at its first instruction, and run to the breakpoint. +** Note: the semantics of this word are equivalent to "step in" +**************************************************************************/ +void ficlDebugXT(FICL_VM *pVM) +{ + FICL_WORD *xt = stackPopPtr(pVM->pStack); + WORDKIND wk = ficlWordClassify(xt); + FICL_WORD *pStep = ficlLookup("step-break"); + + assert(pStep); + + stackPushPtr(pVM->pStack, xt); + seeXT(pVM); + + switch (wk) + { + case COLON: + case DOES: + /* + ** Run the colon code and set a breakpoint at the next instruction + */ + vmExecute(pVM, xt); + bpStep.address = pVM->ip; + bpStep.origXT = *pVM->ip; + *pVM->ip = pStep; + break; + + default: + vmExecute(pVM, xt); + break; + } + + return; +} + + +/************************************************************************** + s t e p I n +** FICL +** Execute the next instruction, stepping into it if it's a colon definition +** or a does> word. This is the easy kind of step. +**************************************************************************/ +void stepIn(FICL_VM *pVM) +{ + /* + ** Do one step of the inner loop + */ + { + M_VM_STEP(pVM) + } + + /* + ** Now set a breakpoint at the next instruction + */ + vmSetBreak(pVM, &bpStep); + + return; +} + + +/************************************************************************** + s t e p O v e r +** FICL +** Execute the next instruction atomically. This requires some insight into +** the memory layout of compiled code. Set a breakpoint at the next instruction +** in this word, and run until we hit it +**************************************************************************/ +void stepOver(FICL_VM *pVM) +{ + FICL_WORD *pFW; + WORDKIND kind; + FICL_WORD *pStep = ficlLookup("step-break"); + assert(pStep); + + pFW = *pVM->ip; + kind = ficlWordClassify(pFW); + + switch (kind) + { + case COLON: + case DOES: + /* + ** assume that the next cell holds an instruction + ** set a breakpoint there and return to the inner interp + */ + bpStep.address = pVM->ip + 1; + bpStep.origXT = pVM->ip[1]; + pVM->ip[1] = pStep; + break; + + default: + stepIn(pVM); + break; + } + + return; +} + + +/************************************************************************** + s t e p - b r e a k +** FICL +** Handles breakpoints for stepped execution. +** Upon entry, bpStep contains the address and replaced instruction +** of the current breakpoint. +** Clear the breakpoint +** Get a command from the console. +** i (step in) - execute the current instruction and set a new breakpoint +** at the IP +** o (step over) - execute the current instruction to completion and set +** a new breakpoint at the IP +** g (go) - execute the current instruction and exit +** q (quit) - abort current word +** b (toggle breakpoint) +**************************************************************************/ +void stepBreak(FICL_VM *pVM) +{ + STRINGINFO si; + FICL_WORD *pFW; + FICL_WORD *pOnStep; + + if (!pVM->fRestart) + { + + assert(bpStep.address != NULL); + /* + ** Clear the breakpoint that caused me to run + ** Restore the original instruction at the breakpoint, + ** and restore the IP + */ + assert(bpStep.address); + assert(bpStep.origXT); + + pVM->ip = (IPTYPE)bpStep.address; + *pVM->ip = bpStep.origXT; + + /* + ** If there's an onStep, do it + */ + pOnStep = ficlLookup("on-step"); + if (pOnStep) + ficlExecXT(pVM, pOnStep); + + /* + ** Print the name of the next instruction + */ + pFW = bpStep.origXT; + sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name); + if (isPrimitive(pFW)) + { + strcat(pVM->pad, " primitive"); + } + + vmTextOut(pVM, pVM->pad, 1); + } + else + { + pVM->fRestart = 0; + } + + si = vmGetWord(pVM); + + if (!strincmp(si.cp, "i", si.count)) + { + stepIn(pVM); + } + else if (!strincmp(si.cp, "g", si.count)) + { + return; + } + else if (!strincmp(si.cp, "o", si.count)) + { + stepOver(pVM); + } + else if (!strincmp(si.cp, "q", si.count)) + { + vmThrow(pVM, VM_ABORT); + } + else + { + vmTextOut(pVM, "i -- step In", 1); + vmTextOut(pVM, "o -- step Over", 1); + vmTextOut(pVM, "g -- Go (execute to completion)", 1); + vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1); + vmTextOut(pVM, "x -- eXecute a single word", 1); + vmThrow(pVM, VM_RESTART); + } + + 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; +} + + +/************************************************************************** + d i s p l a y S t a c k +** TOOLS +** 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) ", 0); + else + { + pCell = pVM->pStack->base; + for (i = 0; i < d; i++) + { + vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0); + vmTextOut(pVM, " ", 0); + } + } +} + + +static void displayRStack(FICL_VM *pVM) +{ + int d = stackDepth(pVM->rStack); + int i; + CELL *pCell; + + vmTextOut(pVM, "Return Stack: ", 0); + if (d == 0) + vmTextOut(pVM, "Empty ", 0); + else + { + pCell = pVM->rStack->base; + for (i = 0; i < d; i++) + { + vmTextOut(pVM, ultoa((*pCell++).i, pVM->pad, 16), 0); + vmTextOut(pVM, " ", 0); + } + } +} + + +/************************************************************************** + f o r g e t - w i d +** +**************************************************************************/ +static void forgetWid(FICL_VM *pVM) +{ + FICL_DICT *pDict = ficlGetDict(); + FICL_HASH *pHash; + + pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); + hashForget(pHash, pDict->here); + + return; +} + + +/************************************************************************** + f o r g e t +** TOOLS EXT ( "<spaces>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 forget(FICL_VM *pVM) +{ + void *where; + FICL_DICT *pDict = ficlGetDict(); + FICL_HASH *pHash = pDict->pCompile; + + ficlTick(pVM); + where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; + hashForget(pHash, where); + pDict->here = PTRtoCELL where; + + 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 %u total", + nWords, (long) (dp->here - dp->dict), dp->size); + vmTextOut(pVM, pVM->pad, 1); + return; +} + + +/************************************************************************** + l i s t E n v +** Print symbols defined in the environment +**************************************************************************/ +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 %u total", + nWords, (long) (dp->here - dp->dict), dp->size); + vmTextOut(pVM, pVM->pad, 1); + return; +} + + +/************************************************************************** + e n v C o n s t a n t +** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set +** environment constants... +**************************************************************************/ +static void envConstant(FICL_VM *pVM) +{ + unsigned value; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + vmGetWordToPad(pVM); + value = POPUNS(); + ficlSetEnv(pVM->pad, (FICL_UNS)value); + return; +} + +static void env2Constant(FICL_VM *pVM) +{ + unsigned v1, v2; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 0); +#endif + + vmGetWordToPad(pVM); + v2 = POPUNS(); + v1 = POPUNS(); + ficlSetEnvD(pVM->pad, v1, v2); + return; +} + + +/************************************************************************** + f i c l C o m p i l e T o o l s +** Builds wordset for debugger and TOOLS optional word set +**************************************************************************/ + +void ficlCompileTools(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + assert (dp); + + /* + ** TOOLS and TOOLS EXT + */ + dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); /* guy carver */ + 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, "env-constant", + envConstant, FW_DEFAULT); + dictAppendWord(dp, "env-2constant", + env2Constant, FW_DEFAULT); + dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT); + dictAppendWord(dp, "parse-order", + ficlListParseSteps, + FW_DEFAULT); + dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT); + dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); + dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT); + dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); + + return; +} + diff --git a/sys/boot/ficl/unix.c b/sys/boot/ficl/unix.c new file mode 100644 index 0000000..4400752 --- /dev/null +++ b/sys/boot/ficl/unix.c @@ -0,0 +1,23 @@ +/* $FreeBSD$ */ + +#include <string.h> +#include <netinet/in.h> + +#include "ficl.h" + + + +unsigned long ficlNtohl(unsigned long number) + { + return ntohl(number); + } + + + + +void ficlCompilePlatform(FICL_DICT *dp) +{ + return; +} + + diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c index 3608d29..bebba71 100644 --- a/sys/boot/ficl/vm.c +++ b/sys/boot/ficl/vm.c @@ -3,7 +3,7 @@ ** Forth Inspired Command Language - virtual machine methods ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** +** $Id: vm.c,v 1.8 2001-04-26 21:41:23-07 jsadler Exp jsadler $ *******************************************************************/ /* ** This file implements the virtual machine of FICL. Each virtual @@ -12,6 +12,42 @@ ** well as a pile of state variables and the two dedicated registers ** of the interp. */ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: vm.c,v 1.8 2001-04-26 21:41:23-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -42,7 +78,9 @@ void vmBranchRelative(FICL_VM *pVM, int offset) /************************************************************************** v m C r e a t e -** +** Creates a virtual machine either from scratch (if pVM is NULL on entry) +** or by resizing and reinitializing an existing VM to the specified stack +** sizes. **************************************************************************/ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) { @@ -61,6 +99,12 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) stackDelete(pVM->rStack); pVM->rStack = stackCreate(nRStack); +#if FICL_WANT_FLOAT + if (pVM->fStack) + stackDelete(pVM->fStack); + pVM->fStack = stackCreate(nPStack); +#endif + pVM->textOut = ficlTextOut; vmReset(pVM); @@ -70,7 +114,8 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) /************************************************************************** v m D e l e t e -** +** Free all memory allocated to the specified VM and its subordinate +** structures. **************************************************************************/ void vmDelete (FICL_VM *pVM) { @@ -78,6 +123,9 @@ void vmDelete (FICL_VM *pVM) { ficlFree(pVM->pStack); ficlFree(pVM->rStack); +#if FICL_WANT_FLOAT + ficlFree(pVM->fStack); +#endif ficlFree(pVM); } @@ -200,7 +248,7 @@ STRINGINFO vmGetWord0(FICL_VM *pVM) /************************************************************************** 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 +** Does vmGetWord and copies the result to the pad as a NULL terminated ** string. Returns the length of the string. If the string is too long ** to fit in the pad, it is truncated. **************************************************************************/ @@ -208,7 +256,7 @@ int vmGetWordToPad(FICL_VM *pVM) { STRINGINFO si; char *cp = (char *)pVM->pad; - si = vmGetWord0(pVM); + si = vmGetWord(pVM); if (SI_COUNT(si) > nPAD) SI_SETLEN(si, nPAD); @@ -231,7 +279,7 @@ int vmGetWordToPad(FICL_VM *pVM) **************************************************************************/ STRINGINFO vmParseString(FICL_VM *pVM, char delim) { - return vmParseStringEx(pVM, delim, 1); + return vmParseStringEx(pVM, delim, 1); } STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) @@ -241,11 +289,11 @@ STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading) char *pEnd = vmGetInBufEnd(pVM); char ch; - if (fSkipLeading) - { /* skip lead delimiters */ - while ((pSrc != pEnd) && (*pSrc == delim)) - pSrc++; - } + if (fSkipLeading) + { /* skip lead delimiters */ + while ((pSrc != pEnd) && (*pSrc == delim)) + pSrc++; + } SI_SETPTR(si, pSrc); /* mark start of text */ @@ -345,15 +393,10 @@ void vmPopTib(FICL_VM *pVM, TIB *pTib) **************************************************************************/ 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->ip = NULL; + pVM->runningWord = NULL; pVM->state = INTERPRET; pVM->tib.cp = NULL; pVM->tib.end = NULL; @@ -372,6 +415,9 @@ void vmReset(FICL_VM *pVM) { vmQuit(pVM); stackReset(pVM->pStack); +#if FICL_WANT_FLOAT + stackReset(pVM->fStack); +#endif pVM->base = 10; return; } @@ -400,7 +446,7 @@ void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut) #if FICL_WANT_DEBUGGER void vmStep(FICL_VM *pVM) { - M_VM_STEP(pVM); + M_VM_STEP(pVM); } #endif @@ -629,25 +675,23 @@ char *caseFold(char *cp) /************************************************************************** s t r i n c m p -** +** (jws) simplified the code a bit in hopes of appeasing Purify **************************************************************************/ -int strincmp(char *cp1, char *cp2, FICL_COUNT count) +int strincmp(char *cp1, char *cp2, FICL_UNS count) { int i = 0; - char c1, c2; - for (c1 = *cp1, c2 = *cp2; - ((i == 0) && count && c1 && c2); - c1 = *++cp1, c2 = *++cp2, count--) + for (; 0 < count; ++cp1, ++cp2, --count) { - i = tolower(c1) - tolower(c2); + i = tolower(*cp1) - tolower(*cp2); + if (i != 0) + return i; + else if (*cp1 == '\0') + return 0; } - - return i; + return 0; } - - /************************************************************************** s k i p S p a c e ** Given a string pointer, returns a pointer to the first non-space diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c index 36ea902..4a7d1a5 100644 --- a/sys/boot/ficl/words.c +++ b/sys/boot/ficl/words.c @@ -4,8 +4,44 @@ ** ANS Forth CORE word-set written in C ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 19 July 1997 -** +** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $ *******************************************************************/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +** +** I am interested in hearing from anyone who uses ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the ficl release, please send +** contact me by email at the address above. +** +** $Id: words.c,v 1.11 2001-04-26 21:41:15-07 jsadler Exp jsadler $ +*/ /* $FreeBSD$ */ @@ -23,7 +59,7 @@ static void colonParen(FICL_VM *pVM); static void literalIm(FICL_VM *pVM); -static void interpWord(FICL_VM *pVM, STRINGINFO si); +static int ficlParseWord(FICL_VM *pVM, STRINGINFO si); /* ** Control structure building words use these @@ -55,6 +91,7 @@ static FICL_WORD *pLitParen = NULL; static FICL_WORD *pTwoLitParen = NULL; static FICL_WORD *pLoopParen = NULL; static FICL_WORD *pPLoopParen = NULL; +static FICL_WORD *pPlusStore = NULL; static FICL_WORD *pQDoParen = NULL; static FICL_WORD *pSemiParen = NULL; static FICL_WORD *pStore = NULL; @@ -89,21 +126,28 @@ static void do2LocalIm(FICL_VM *pVM); */ static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) { - stackPushPtr(pVM->pStack, dp->here); - stackPushPtr(pVM->pStack, tag); + PUSHPTR(dp->here); + PUSHPTR(tag); return; } static void markControlTag(FICL_VM *pVM, char *tag) { - stackPushPtr(pVM->pStack, tag); + PUSHPTR(tag); return; } static void matchControlTag(FICL_VM *pVM, char *tag) { - char *cp = (char *)stackPopPtr(pVM->pStack); - if ( strcmp(cp, tag) ) + char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + cp = (char *)stackPopPtr(pVM->pStack); + /* + ** Changed the code below to compare the pointers first (by popular demand) + */ + if ( (cp != tag) && strcmp(cp, tag) ) { vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag); } @@ -123,6 +167,9 @@ static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) matchControlTag(pVM, tag); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif patchAddr = (CELL *)stackPopPtr(pVM->pStack); offset = patchAddr - dp->here; dictAppendCell(dp, LVALUEtoCELL(offset)); @@ -143,6 +190,9 @@ static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) matchControlTag(pVM, tag); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif patchAddr = (CELL *)stackPopPtr(pVM->pStack); offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); @@ -160,8 +210,14 @@ static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) CELL *patchAddr; char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 0); +#endif cp = stackPopPtr(pVM->pStack); - if (strcmp(cp, tag)) + /* + ** Changed the comparison below to compare the pointers first (by popular demand) + */ + if ((cp != tag) && strcmp(cp, tag)) { vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); vmTextOut(pVM, tag, 1); @@ -175,15 +231,15 @@ static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) /************************************************************************** - i s N u m b e r + f i c l P a r s e N u m b e r ** Attempts to convert the NULL terminated string in the VM's pad to ** a number using the VM's current base. If successful, pushes the number ** onto the param stack and returns TRUE. Otherwise, returns FALSE. **************************************************************************/ -static int isNumber(FICL_VM *pVM, STRINGINFO si) +int ficlParseNumber(FICL_VM *pVM, STRINGINFO si) { - FICL_INT accum = 0; + FICL_INT accum = 0; char isNeg = FALSE; unsigned base = pVM->base; char *cp = SI_PTR(si); @@ -191,25 +247,31 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si) unsigned ch; unsigned digit; - if (*cp == '-') + if (count > 1) { - cp++; - count--; - isNeg = TRUE; - } - else if ((cp[0] == '0') && (cp[1] == 'x')) - { /* detect 0xNNNN format for hex numbers */ - cp += 2; - count -= 2; - base = 16; + switch (*cp) + { + case '-': + cp++; + count--; + isNeg = TRUE; + break; + case '+': + cp++; + count--; + isNeg = FALSE; + break; + default: + break; + } } if (count == 0) return FALSE; - while (count-- && ((ch = *cp++) != '\0')) + while ((count--) && ((ch = *cp++) != '\0')) { - if (!(isdigit(ch)||isalpha(ch))) + if (!isalnum(ch)) return FALSE; digit = ch - '0'; @@ -226,24 +288,14 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si) if (isNeg) accum = -accum; - stackPushINT(pVM->pStack, accum); + PUSHINT(accum); + if (pVM->state == COMPILE) + literalIm(pVM); 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 ** @@ -292,7 +344,7 @@ static void negate(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif i = -stackPopINT(pVM->pStack); - stackPushINT(pVM->pStack, i); + PUSHINT(i); return; } @@ -331,8 +383,8 @@ static void slashMod(FICL_VM *pVM) i64Extend(n1); qr = m64SymmetricDivI(n1, n2); - stackPushINT(pVM->pStack, qr.rem); - stackPushINT(pVM->pStack, qr.quot); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } @@ -398,7 +450,7 @@ static void mulDiv(FICL_VM *pVM) prod = m64MulI(x,y); x = m64SymmetricDivI(prod, z).quot; - stackPushINT(pVM->pStack, x); + PUSHINT(x); return; } @@ -418,22 +470,8 @@ static void mulDivRem(FICL_VM *pVM) 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); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } @@ -642,18 +680,6 @@ static void displayCell(FICL_VM *pVM) 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; @@ -683,32 +709,6 @@ static void hexDot(FICL_VM *pVM) /************************************************************************** - 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 ** **************************************************************************/ @@ -720,7 +720,7 @@ static void depth(FICL_VM *pVM) vmCheckStack(pVM, 0, 1); #endif i = stackDepth(pVM->pStack); - stackPushINT(pVM->pStack, i); + PUSHINT(i); return; } @@ -1018,18 +1018,18 @@ static void plusStore(FICL_VM *pVM) } -static void iFetch(FICL_VM *pVM) +static void quadFetch(FICL_VM *pVM) { UNS32 *pw; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif pw = (UNS32 *)stackPopPtr(pVM->pStack); - stackPushUNS(pVM->pStack, (FICL_UNS)*pw); + PUSHUNS((FICL_UNS)*pw); return; } -static void iStore(FICL_VM *pVM) +static void quadStore(FICL_VM *pVM) { UNS32 *pw; #if FICL_ROBUST > 1 @@ -1046,7 +1046,7 @@ static void wFetch(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif pw = (UNS16 *)stackPopPtr(pVM->pStack); - stackPushUNS(pVM->pStack, (FICL_UNS)*pw); + PUSHUNS((FICL_UNS)*pw); return; } @@ -1067,7 +1067,7 @@ static void cFetch(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif pc = (UNS8 *)stackPopPtr(pVM->pStack); - stackPushUNS(pVM->pStack, (FICL_UNS)*pc); + PUSHUNS((FICL_UNS)*pc); return; } @@ -1125,7 +1125,7 @@ static void ifParen(FICL_VM *pVM) } else { /* take branch (to else/endif/begin) */ - vmBranchRelative(pVM, *(int*)(pVM->ip)); + vmBranchRelative(pVM, *(int *)(pVM->ip)); } return; @@ -1200,10 +1200,10 @@ static void endifCoIm(FICL_VM *pVM) 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)); + STRINGINFO si; + SI_SETLEN(si, stackPopUNS(pVM->pStack)); + SI_SETPTR(si, stackPopPtr(pVM->pStack)); + PUSHUNS(hashHashCode(si)); return; } @@ -1229,10 +1229,13 @@ static void hash(FICL_VM *pVM) static void interpret(FICL_VM *pVM) { - STRINGINFO si = vmGetWord0(pVM); - assert(pVM); + STRINGINFO si; + int i; + FICL_SYSTEM *pSys; - vmBranchRelative(pVM, -1); + assert(pVM); + pSys = pVM->pSys; + si = vmGetWord0(pVM); /* ** Get next word...if out of text, we're done. @@ -1242,13 +1245,38 @@ static void interpret(FICL_VM *pVM) vmThrow(pVM, VM_OUTOFTEXT); } - interpWord(pVM, si); + /* + ** Attempt to find the incoming token in the dictionary. If that fails... + ** run the parse chain against the incoming token until somebody eats it. + ** Otherwise emit an error message and give up. + ** Although ficlParseWord could be part of the parse list, I've hard coded it + ** in for robustness. ficlInitSystem adds the other default steps to the list. + */ + if (ficlParseWord(pVM, si)) + return; + for (i=0; i < FICL_MAX_PARSE_STEPS; i++) + { + FICL_WORD *pFW = pSys->parseList[i]; + FICL_PARSE_STEP pStep; + + if (pFW == NULL) + break; + + pStep = (FICL_PARSE_STEP)(pFW->param->fn); + if ((*pStep)(pVM, si)) + return; + } + + i = SI_COUNT(si); + vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); return; /* back to inner interpreter */ } + /************************************************************************** + f i c l P a r s e W o r d ** From the standard, section 3.4 ** b) Search the dictionary name space (see 3.4.2). If a definition name ** matching the string is found: @@ -1264,8 +1292,10 @@ static void interpret(FICL_VM *pVM) ** the stack (see 6.1.1780 LITERAL), and continue at a); ** ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). +** +** (jws 4/01) Modified to be a FICL_PARSE_STEP **************************************************************************/ -static void interpWord(FICL_VM *pVM, STRINGINFO si) +static int ficlParseWord(FICL_VM *pVM, STRINGINFO si) { FICL_DICT *dp = ficlGetDict(); FICL_WORD *tempFW; @@ -1294,12 +1324,7 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si) } vmExecute(pVM, tempFW); - } - - else if (!isNumber(pVM, si)) - { - int i = SI_COUNT(si); - vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); + return FICL_TRUE; } } @@ -1315,18 +1340,46 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si) { 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 FICL_TRUE; } } + return FICL_FALSE; +} + + +/************************************************************************** + p a r e n P a r s e S t e p +** (parse-step) ( c-addr u -- flag ) +** runtime for a precompiled parse step - pop a counted string off the +** stack, run the parse step against it, and push the result flag (FICL_TRUE +** if success, FICL_FALSE otherwise). +**************************************************************************/ + +void parseStepParen(FICL_VM *pVM) +{ + STRINGINFO si; + FICL_WORD *pFW = pVM->runningWord; + FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn); + + SI_SETLEN(si, stackPopINT(pVM->pStack)); + SI_SETPTR(si, stackPopPtr(pVM->pStack)); + + PUSHINT((*pStep)(pVM, si)); + + return; +} + + +static void addParseStep(FICL_VM *pVM) +{ + FICL_WORD *pStep; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + pStep = (FICL_WORD *)(stackPop(pVM->pStack).p); + if ((pStep != NULL) && isAFiclWord(pStep)) + ficlAddParseStep(pVM->pSys, pStep); return; } @@ -1345,7 +1398,7 @@ static void literalParen(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif - stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip)); + PUSHINT(*(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 1); return; } @@ -1355,8 +1408,8 @@ 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)); + PUSHINT(*((FICL_INT *)(pVM->ip)+1)); + PUSHINT(*(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 2); return; } @@ -1395,107 +1448,6 @@ static void twoLiteralIm(FICL_VM *pVM) } /************************************************************************** - 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 %u total", - nWords, (long) (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 %u total", - nWords, (long) (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 ** **************************************************************************/ @@ -1542,7 +1494,7 @@ static void isEqual(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, FICL_BOOL(x.i == y.i)); + PUSHINT(FICL_BOOL(x.i == y.i)); return; } @@ -1554,7 +1506,7 @@ static void isLess(FICL_VM *pVM) #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, FICL_BOOL(x.i < y.i)); + PUSHINT(FICL_BOOL(x.i < y.i)); return; } @@ -1566,7 +1518,7 @@ static void uIsLess(FICL_VM *pVM) #endif u2 = stackPopUNS(pVM->pStack); u1 = stackPopUNS(pVM->pStack); - stackPushINT(pVM->pStack, FICL_BOOL(u1 < u2)); + PUSHINT(FICL_BOOL(u1 < u2)); return; } @@ -1578,7 +1530,7 @@ static void isGreater(FICL_VM *pVM) #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i)); + PUSHINT(FICL_BOOL(x.i > y.i)); return; } @@ -1590,7 +1542,7 @@ static void bitwiseAnd(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, x.i & y.i); + PUSHINT(x.i & y.i); return; } @@ -1602,7 +1554,7 @@ static void bitwiseOr(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, x.i | y.i); + PUSHINT(x.i | y.i); return; } @@ -1614,7 +1566,7 @@ static void bitwiseXor(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, x.i ^ y.i); + PUSHINT(x.i ^ y.i); return; } @@ -1625,7 +1577,7 @@ static void bitwiseNot(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif x = stackPop(pVM->pStack); - stackPushINT(pVM->pStack, ~x.i); + PUSHINT(~x.i); return; } @@ -1815,12 +1767,18 @@ static void loopParen(FICL_VM *pVM) static void plusLoopParen(FICL_VM *pVM) { - FICL_INT index = stackGetTop(pVM->rStack).i; - FICL_INT limit = stackFetch(pVM->rStack, 1).i; - FICL_INT increment = stackPop(pVM->pStack).i; - int flag; + FICL_INT index,limit,increment; + int flag; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif - index += increment; + index = stackGetTop(pVM->rStack).i; + limit = stackFetch(pVM->rStack, 1).i; + increment = POP().i; + + index += increment; if (increment < 0) flag = (index < limit); @@ -1873,22 +1831,62 @@ static void loopKCo(FICL_VM *pVM) r e t u r n s t a c k ** **************************************************************************/ - static void toRStack(FICL_VM *pVM) { +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + stackPush(pVM->rStack, POP()); +} + +static void fromRStack(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + PUSH(stackPop(pVM->rStack)); +} + +static void fetchRStack(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + PUSH(stackGetTop(pVM->rStack)); +} + +static void twoToR(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 0); +#endif + stackRoll(pVM->pStack, 1); + stackPush(pVM->rStack, stackPop(pVM->pStack)); stackPush(pVM->rStack, stackPop(pVM->pStack)); return; } -static void fromRStack(FICL_VM *pVM) +static void twoRFrom(FICL_VM *pVM) { +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 2); +#endif stackPush(pVM->pStack, stackPop(pVM->rStack)); + stackPush(pVM->pStack, stackPop(pVM->rStack)); + stackRoll(pVM->pStack, 1); return; } -static void fetchRStack(FICL_VM *pVM) +static void twoRFetch(FICL_VM *pVM) { - stackPush(pVM->pStack, stackGetTop(pVM->rStack)); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 2); +#endif + stackPush(pVM->pStack, stackFetch(pVM->rStack, 1)); + stackPush(pVM->pStack, stackFetch(pVM->rStack, 0)); return; } @@ -1900,9 +1898,13 @@ static void fetchRStack(FICL_VM *pVM) static void variableParen(FICL_VM *pVM) { - FICL_WORD *fw = pVM->runningWord; - stackPushPtr(pVM->pStack, fw->param); - return; + FICL_WORD *fw; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + fw = pVM->runningWord; + PUSHPTR(fw->param); } @@ -1917,6 +1919,16 @@ static void variable(FICL_VM *pVM) } +static void twoVariable(FICL_VM *pVM) +{ + FICL_DICT *dp = ficlGetDict(); + STRINGINFO si = vmGetWord(pVM); + + dictAppendWord2(dp, si, variableParen, FW_DEFAULT); + dictAllotCells(dp, 2); + return; +} + /************************************************************************** b a s e & f r i e n d s @@ -1925,9 +1937,13 @@ static void variable(FICL_VM *pVM) static void base(FICL_VM *pVM) { - CELL *pBase = (CELL *)(&pVM->base); - stackPush(pVM->pStack, LVALUEtoCELL(pBase)); - return; + CELL *pBase; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + pBase = (CELL *)(&pVM->base); + PUSH(*pBase); } @@ -1952,58 +1968,90 @@ static void hex(FICL_VM *pVM) static void allot(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - FICL_INT i = stackPopINT(pVM->pStack); + FICL_DICT *dp; + FICL_INT i; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + dp = ficlGetDict(); + i = POPINT(); + #if FICL_ROBUST - dictCheck(dp, pVM, i); + dictCheck(dp, pVM, i); #endif - dictAllot(dp, i); + + dictAllot(dp, i); return; } static void here(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - stackPushPtr(pVM->pStack, dp->here); + FICL_DICT *dp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + dp = ficlGetDict(); + PUSHPTR(dp->here); return; } - static void comma(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - CELL c = stackPop(pVM->pStack); - dictAppendCell(dp, c); + FICL_DICT *dp; + CELL c; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + dp = ficlGetDict(); + c = POP(); + dictAppendCell(dp, c); return; } - static void cComma(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - char c = (char)stackPopINT(pVM->pStack); - dictAppendChar(dp, c); + FICL_DICT *dp; + char c; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + dp = ficlGetDict(); + c = (char)POPINT(); + dictAppendChar(dp, c); return; } - static void cells(FICL_VM *pVM) { - FICL_INT i = stackPopINT(pVM->pStack); - stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL)); + FICL_INT i; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 1); +#endif + + i = POPINT(); + PUSHINT(i * (FICL_INT)sizeof (CELL)); return; } - static void cellPlus(FICL_VM *pVM) { - char *cp = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, cp + sizeof (CELL)); + char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 1); +#endif + + cp = POPPTR(); + PUSHPTR(cp + sizeof (CELL)); return; } + /************************************************************************** t i c k ** tick CORE ( "<spaces>name" -- xt ) @@ -2011,25 +2059,28 @@ static void cellPlus(FICL_VM *pVM) ** name and return xt, the execution token for name. An ambiguous condition ** exists if name is not found. **************************************************************************/ -static void tick(FICL_VM *pVM) +void ficlTick(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); + FICL_WORD *pFW = NULL; + STRINGINFO si = vmGetWord(pVM); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + pFW = dictLookup(ficlGetDict(), si); + if (!pFW) + { + int i = SI_COUNT(si); + vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); + } + PUSHPTR(pFW); return; } static void bracketTickCoIm(FICL_VM *pVM) { - tick(pVM); + ficlTick(pVM); literalIm(pVM); return; @@ -2049,7 +2100,7 @@ static void postponeCoIm(FICL_VM *pVM) FICL_WORD *pFW; assert(pComma); - tick(pVM); + ficlTick(pVM); pFW = stackGetTop(pVM->pStack).p; if (wordIsImmediate(pFW)) { @@ -2122,15 +2173,21 @@ static void compileOnly(FICL_VM *pVM) static void stringLit(FICL_VM *pVM) { - 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; + FICL_STRING *sp; + FICL_COUNT count; + char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 2); +#endif + + sp = (FICL_STRING *)(pVM->ip); + count = sp->count; + cp = sp->text; + PUSHPTR(cp); + PUSHUNS(count); + cp += count + 1; + cp = alignPtr(cp); + pVM->ip = (IPTYPE)(void *)cp; } static void dotQuoteCoIm(FICL_VM *pVM) @@ -2151,6 +2208,9 @@ static void dotParen(FICL_VM *pVM) char *pDest = pVM->pad; char ch; + /* + ** Note: the standard does not want leading spaces skipped (apparently) + */ for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) *pDest++ = ch; @@ -2178,11 +2238,17 @@ static void dotParen(FICL_VM *pVM) **************************************************************************/ static void sLiteralCoIm(FICL_VM *pVM) { - FICL_DICT *dp = ficlGetDict(); - char *cp, *cpDest; - FICL_UNS u; - u = stackPopUNS(pVM->pStack); - cp = stackPopPtr(pVM->pStack); + FICL_DICT *dp; + char *cp, *cpDest; + FICL_UNS u; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 0); +#endif + + dp = ficlGetDict(); + u = POPUNS(); + cp = POPPTR(); dictAppendCell(dp, LVALUEtoCELL(pStringLit)); cpDest = (char *) dp->here; @@ -2206,7 +2272,10 @@ static void sLiteralCoIm(FICL_VM *pVM) **************************************************************************/ static void state(FICL_VM *pVM) { - stackPushPtr(pVM->pStack, &pVM->state); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + PUSHPTR(&pVM->state); return; } @@ -2220,8 +2289,14 @@ static void state(FICL_VM *pVM) static void createParen(FICL_VM *pVM) { - CELL *pCell = pVM->runningWord->param; - stackPushPtr(pVM->pStack, pCell+1); + CELL *pCell; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + pCell = pVM->runningWord->param; + PUSHPTR(pCell+1); return; } @@ -2239,10 +2314,16 @@ static void create(FICL_VM *pVM) static void doDoes(FICL_VM *pVM) { - CELL *pCell = pVM->runningWord->param; - IPTYPE tempIP = (IPTYPE)((*pCell).p); - stackPushPtr(pVM->pStack, pCell+1); - vmPushIP(pVM, tempIP); + CELL *pCell; + IPTYPE tempIP; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 1); +#endif + + pCell = pVM->runningWord->param; + tempIP = (IPTYPE)((*pCell).p); + PUSHPTR(pCell+1); + vmPushIP(pVM, tempIP); return; } @@ -2286,8 +2367,14 @@ static void doesCoIm(FICL_VM *pVM) **************************************************************************/ static void toBody(FICL_VM *pVM) { - FICL_WORD *pFW = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, pFW->param + 1); + FICL_WORD *pFW; +/*#$-GUY CHANGE: Added robustness.-$#*/ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 1); +#endif + + pFW = POPPTR(); + PUSHPTR(pFW->param + 1); return; } @@ -2298,8 +2385,13 @@ static void toBody(FICL_VM *pVM) */ static void fromBody(FICL_VM *pVM) { - char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD); - stackPushPtr(pVM->pStack, ptr); + char *ptr; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 1); +#endif + + ptr = (char *)POPPTR() - sizeof (FICL_WORD); + PUSHPTR(ptr); return; } @@ -2311,9 +2403,24 @@ static void fromBody(FICL_VM *pVM) */ static void toName(FICL_VM *pVM) { - FICL_WORD *pFW = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, pFW->name); - stackPushUNS(pVM->pStack, pFW->nName); + FICL_WORD *pFW; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 2); +#endif + + pFW = POPPTR(); + PUSHPTR(pFW->name); + PUSHUNS(pFW->nName); + return; +} + + +static void getLastWord(FICL_VM *pVM) +{ + FICL_DICT *pDict = ficlGetDict(); + FICL_WORD *wp = pDict->smudge; + assert(wp); + vmPush(pVM, LVALUEtoCELL(wp)); return; } @@ -2361,14 +2468,18 @@ static void lessNumberSign(FICL_VM *pVM) */ 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); + FICL_STRING *sp; + DPUNS u; + UNS16 rem; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 2); +#endif + + sp = PTRtoSTRING pVM->pad; + u = u64Pop(pVM->pStack); + rem = m64UMod(&u, (UNS16)(pVM->base)); + sp->text[sp->count++] = digit_to_char(rem); + u64Push(pVM->pStack, u); return; } @@ -2380,12 +2491,17 @@ static void numberSign(FICL_VM *pVM) */ 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); + FICL_STRING *sp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 2); +#endif + + sp = PTRtoSTRING pVM->pad; + sp->text[sp->count] = 0; + strrev(sp->text); + DROP(2); + PUSHPTR(sp->text); + PUSHUNS(sp->count); return; } @@ -2398,20 +2514,24 @@ static void numberSignGreater(FICL_VM *pVM) */ static void numberSignS(FICL_VM *pVM) { - FICL_STRING *sp = PTRtoSTRING pVM->pad; - DPUNS u; - UNS16 rem; + FICL_STRING *sp; + DPUNS u; + UNS16 rem; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 2); +#endif - u = u64Pop(pVM->pStack); + sp = PTRtoSTRING pVM->pad; + u = u64Pop(pVM->pStack); - do - { - rem = m64UMod(&u, (UNS16)(pVM->base)); - sp->text[sp->count++] = digit_to_char(rem); - } - while (u.hi || u.lo); + do + { + rem = m64UMod(&u, (UNS16)(pVM->base)); + sp->text[sp->count++] = digit_to_char(rem); + } + while (u.hi || u.lo); - u64Push(pVM->pStack, u); + u64Push(pVM->pStack, u); return; } @@ -2422,9 +2542,15 @@ static void numberSignS(FICL_VM *pVM) */ static void hold(FICL_VM *pVM) { - FICL_STRING *sp = PTRtoSTRING pVM->pad; - int i = stackPopINT(pVM->pStack); - sp->text[sp->count++] = (char) i; + FICL_STRING *sp; + int i; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + sp = PTRtoSTRING pVM->pad; + i = POPINT(); + sp->text[sp->count++] = (char) i; return; } @@ -2436,10 +2562,16 @@ static void hold(FICL_VM *pVM) */ static void sign(FICL_VM *pVM) { - FICL_STRING *sp = PTRtoSTRING pVM->pad; - int i = stackPopINT(pVM->pStack); - if (i < 0) - sp->text[sp->count++] = '-'; + FICL_STRING *sp; + int i; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + sp = PTRtoSTRING pVM->pad; + i = POPINT(); + if (i < 0) + sp->text[sp->count++] = '-'; return; } @@ -2460,13 +2592,19 @@ static void sign(FICL_VM *pVM) **************************************************************************/ 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; + FICL_UNS count; + char *cp; + DPUNS accum; + FICL_UNS base = pVM->base; + FICL_UNS ch; + FICL_UNS digit; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,4,4); +#endif + + count = POPUNS(); + cp = (char *)POPPTR(); accum = u64Pop(pVM->pStack); for (ch = *cp; count > 0; ch = *++cp, count--) @@ -2489,8 +2627,8 @@ static void toNumber(FICL_VM *pVM) } u64Push(pVM->pStack, accum); - stackPushPtr (pVM->pStack, cp); - stackPushUNS(pVM->pStack, count); + PUSHPTR(cp); + PUSHUNS(count); return; } @@ -2547,12 +2685,17 @@ static void ficlAbort(FICL_VM *pVM) **************************************************************************/ static void accept(FICL_VM *pVM) { - FICL_INT count; - char *cp; - char *pBuf = vmGetInBuf(pVM); - char *pEnd = vmGetInBufEnd(pVM); - FICL_INT len = pEnd - pBuf; + FICL_UNS count, len; + char *cp; + char *pBuf, *pEnd; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif + + pBuf = vmGetInBuf(pVM); + pEnd = vmGetInBufEnd(pVM); + len = pEnd - pBuf; if (len == 0) vmThrow(pVM, VM_RESTART); @@ -2566,7 +2709,7 @@ static void accept(FICL_VM *pVM) strncpy(cp, vmGetInBuf(pVM), len); pBuf += len; vmUpdateTib(pVM, pBuf); - stackPushINT(pVM->pStack, len); + PUSHINT(len); return; } @@ -2593,8 +2736,13 @@ static void align(FICL_VM *pVM) **************************************************************************/ static void aligned(FICL_VM *pVM) { - void *addr = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, alignPtr(addr)); + void *addr; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,1); +#endif + + addr = POPPTR(); + PUSHPTR(alignPtr(addr)); return; } @@ -2683,9 +2831,13 @@ static void againCoIm(FICL_VM *pVM) **************************************************************************/ static void ficlChar(FICL_VM *pVM) { - STRINGINFO si = vmGetWord(pVM); - stackPushUNS(pVM->pStack, (FICL_UNS)(si.cp[0])); + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,0,1); +#endif + si = vmGetWord(pVM); + PUSHUNS((FICL_UNS)(si.cp[0])); return; } @@ -2703,8 +2855,13 @@ static void charCoIm(FICL_VM *pVM) **************************************************************************/ static void charPlus(FICL_VM *pVM) { - char *cp = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, cp + 1); + char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,1); +#endif + + cp = POPPTR(); + PUSHPTR(cp + 1); return; } @@ -2720,12 +2877,16 @@ static void charPlus(FICL_VM *pVM) #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! */ + if (sizeof (char) > 1) + { + FICL_INT i; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,1); +#endif + i = POPINT(); + PUSHINT(i * sizeof (char)); + } + /* otherwise no-op! */ return; } #if defined (_M_IX86) @@ -2743,9 +2904,14 @@ static void ficlChars(FICL_VM *pVM) **************************************************************************/ static void count(FICL_VM *pVM) { - FICL_STRING *sp = stackPopPtr(pVM->pStack); - stackPushPtr(pVM->pStack, sp->text); - stackPushUNS(pVM->pStack, sp->count); + FICL_STRING *sp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,2); +#endif + + sp = POPPTR(); + PUSHPTR(sp->text); + PUSHUNS(sp->count); return; } @@ -2764,27 +2930,32 @@ static void count(FICL_VM *pVM) **************************************************************************/ 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; - + FICL_DICT *envp; + FICL_COUNT len; + char *cp; + FICL_WORD *pFW; + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif - &len; /* silence compiler warning... */ - SI_PSZ(si, cp); - pFW = dictLookup(envp, si); + envp = ficlGetEnv(); + len = (FICL_COUNT)POPUNS(); + cp = POPPTR(); - if (pFW != NULL) - { - vmExecute(pVM, pFW); - stackPushINT(pVM->pStack, FICL_TRUE); - } - else - { - stackPushINT(pVM->pStack, FICL_FALSE); - } + IGNORE(len); + SI_PSZ(si, cp); + pFW = dictLookup(envp, si); + if (pFW != NULL) + { + vmExecute(pVM, pFW); + PUSHINT(FICL_TRUE); + } + else + { + PUSHINT(FICL_FALSE); + } return; } @@ -2800,17 +2971,24 @@ static void environmentQ(FICL_VM *pVM) **************************************************************************/ static void evaluate(FICL_VM *pVM) { - FICL_INT count = stackPopINT(pVM->pStack); - char *cp = stackPopPtr(pVM->pStack); - CELL id; + FICL_UNS count; + char *cp; + CELL id; int result; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,0); +#endif + + count = POPUNS(); + cp = POPPTR(); - id = pVM->sourceID; - pVM->sourceID.i = -1; - result = ficlExecC(pVM, cp, count); - pVM->sourceID = id; - if (result != VM_OUTOFTEXT) - vmThrow(pVM, result); + IGNORE(count); + id = pVM->sourceID; + pVM->sourceID.i = -1; + result = ficlExecC(pVM, cp, count); + pVM->sourceID = id; + if (result != VM_OUTOFTEXT) + vmThrow(pVM, result); return; } @@ -2818,7 +2996,7 @@ static void evaluate(FICL_VM *pVM) /************************************************************************** s t r i n g q u o t e -** Intrpreting: get string delimited by a quote from the input stream, +** Interpreting: get string delimited by a quote from the input stream, ** copy to a scratch area, and put its count and address on the stack. ** Compiling: compile code to push the address and count of a string ** literal, compile the string from the input stream, and align the dict @@ -2832,8 +3010,8 @@ static void stringQuoteIm(FICL_VM *pVM) { FICL_STRING *sp = (FICL_STRING *) dp->here; vmGetString(pVM, sp, '\"'); - stackPushPtr(pVM->pStack, sp->text); - stackPushUNS(pVM->pStack, sp->count); + PUSHPTR(sp->text); + PUSHUNS(sp->count); } else /* COMPILE state */ { @@ -2889,20 +3067,27 @@ static void type(FICL_VM *pVM) **************************************************************************/ static void ficlWord(FICL_VM *pVM) { - FICL_STRING *sp = (FICL_STRING *)pVM->pad; - char delim = (char)stackPopINT(pVM->pStack); - STRINGINFO si; - + FICL_STRING *sp; + char delim; + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,1); +#endif + + sp = (FICL_STRING *)pVM->pad; + delim = (char)POPINT(); si = vmParseStringEx(pVM, delim, 1); - if (SI_COUNT(si) > nPAD-1) - SI_SETLEN(si, nPAD-1); + 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, " "); + sp->count = (FICL_COUNT)SI_COUNT(si); + strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); + /*#$-GUY CHANGE: I added this.-$#*/ + sp->text[sp->count] = 0; + strcat(sp->text, " "); - stackPushPtr(pVM->pStack, sp); + PUSHPTR(sp); return; } @@ -2916,9 +3101,14 @@ static void ficlWord(FICL_VM *pVM) **************************************************************************/ static void parseNoCopy(FICL_VM *pVM) { - STRINGINFO si = vmGetWord0(pVM); - stackPushPtr(pVM->pStack, SI_PTR(si)); - stackPushUNS(pVM->pStack, SI_COUNT(si)); + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,0,2); +#endif + + si = vmGetWord0(pVM); + PUSHPTR(SI_PTR(si)); + PUSHUNS(SI_COUNT(si)); return; } @@ -2934,12 +3124,18 @@ static void parseNoCopy(FICL_VM *pVM) **************************************************************************/ static void parse(FICL_VM *pVM) { - STRINGINFO si; - char delim = (char)stackPopINT(pVM->pStack); + STRINGINFO si; + char delim; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,2); +#endif + + delim = (char)POPINT(); si = vmParseStringEx(pVM, delim, 0); - stackPushPtr(pVM->pStack, SI_PTR(si)); - stackPushUNS(pVM->pStack, SI_COUNT(si)); + PUSHPTR(SI_PTR(si)); + PUSHUNS(SI_COUNT(si)); return; } @@ -2952,16 +3148,21 @@ static void parse(FICL_VM *pVM) **************************************************************************/ 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--; - } + char ch; + FICL_UNS u; + char *cp; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,3,0); +#endif + ch = (char)POPINT(); + u = POPUNS(); + cp = (char *)POPPTR(); + while (u > 0) + { + *cp++ = ch; + u--; + } return; } @@ -2978,22 +3179,26 @@ static void fill(FICL_VM *pVM) **************************************************************************/ static void find(FICL_VM *pVM) { - FICL_STRING *sp = stackPopPtr(pVM->pStack); - FICL_WORD *pFW; - STRINGINFO si; + FICL_STRING *sp; + FICL_WORD *pFW; + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,2); +#endif - 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); - } + sp = POPPTR(); + SI_PFS(si, sp); + pFW = dictLookup(ficlGetDict(), si); + if (pFW) + { + PUSHPTR(pFW); + PUSHINT((wordIsImmediate(pFW) ? 1 : -1)); + } + else + { + PUSHPTR(sp); + PUSHUNS(0); + } return; } @@ -3009,15 +3214,18 @@ static void find(FICL_VM *pVM) **************************************************************************/ static void fmSlashMod(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,3,2); +#endif - n1 = stackPopINT(pVM->pStack); - d1 = i64Pop(pVM->pStack); - qr = m64FlooredDivI(d1, n1); - stackPushINT(pVM->pStack, qr.rem); - stackPushINT(pVM->pStack, qr.quot); + n1 = POPINT(); + d1 = i64Pop(pVM->pStack); + qr = m64FlooredDivI(d1, n1); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } @@ -3032,30 +3240,36 @@ static void fmSlashMod(FICL_VM *pVM) **************************************************************************/ static void smSlashRem(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,3,2); +#endif - n1 = stackPopINT(pVM->pStack); - d1 = i64Pop(pVM->pStack); - qr = m64SymmetricDivI(d1, n1); - stackPushINT(pVM->pStack, qr.rem); - stackPushINT(pVM->pStack, qr.quot); + n1 = POPINT(); + d1 = i64Pop(pVM->pStack); + qr = m64SymmetricDivI(d1, n1); + PUSHINT(qr.rem); + PUSHINT(qr.quot); return; } static void ficlMod(FICL_VM *pVM) { - DPINT d1; - FICL_INT n1; - INTQR qr; + DPINT d1; + FICL_INT n1; + INTQR qr; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif - n1 = stackPopINT(pVM->pStack); - d1.lo = stackPopINT(pVM->pStack); - i64Extend(d1); - qr = m64SymmetricDivI(d1, n1); - stackPushINT(pVM->pStack, qr.rem); + n1 = POPINT(); + d1.lo = POPINT(); + i64Extend(d1); + qr = m64SymmetricDivI(d1, n1); + PUSHINT(qr.rem); return; } @@ -3077,8 +3291,8 @@ static void umSlashMod(FICL_VM *pVM) u1 = stackPopUNS(pVM->pStack); ud = u64Pop(pVM->pStack); qr = ficlLongDiv(ud, u1); - stackPushUNS(pVM->pStack, qr.rem); - stackPushUNS(pVM->pStack, qr.quot); + PUSHUNS(qr.rem); + PUSHUNS(qr.quot); return; } @@ -3099,20 +3313,31 @@ static void umSlashMod(FICL_VM *pVM) **************************************************************************/ static void lshift(FICL_VM *pVM) { - FICL_UNS nBits = stackPopUNS(pVM->pStack); - FICL_UNS x1 = stackPopUNS(pVM->pStack); + FICL_UNS nBits; + FICL_UNS x1; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif - stackPushUNS(pVM->pStack, x1 << nBits); + nBits = POPUNS(); + x1 = POPUNS(); + PUSHUNS(x1 << nBits); return; } static void rshift(FICL_VM *pVM) { - FICL_UNS nBits = stackPopUNS(pVM->pStack); - FICL_UNS x1 = stackPopUNS(pVM->pStack); + FICL_UNS nBits; + FICL_UNS x1; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif + + nBits = POPUNS(); + x1 = POPUNS(); - stackPushUNS(pVM->pStack, x1 >> nBits); + PUSHUNS(x1 >> nBits); return; } @@ -3124,24 +3349,36 @@ static void rshift(FICL_VM *pVM) **************************************************************************/ 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); + FICL_INT n2; + FICL_INT n1; + DPINT d; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,2); +#endif + + n2 = POPINT(); + n1 = POPINT(); + + d = m64MulI(n1, n2); + i64Push(pVM->pStack, d); return; } static void umStar(FICL_VM *pVM) { - FICL_UNS u2 = stackPopUNS(pVM->pStack); - FICL_UNS u1 = stackPopUNS(pVM->pStack); - DPUNS ud; - - ud = ficlLongMul(u1, u2); - u64Push(pVM->pStack, ud); + FICL_UNS u2; + FICL_UNS u1; + DPUNS ud; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,2); +#endif + + u2 = POPUNS(); + u1 = POPUNS(); + + ud = ficlLongMul(u1, u2); + u64Push(pVM->pStack, ud); return; } @@ -3152,19 +3389,31 @@ static void umStar(FICL_VM *pVM) **************************************************************************/ static void ficlMax(FICL_VM *pVM) { - FICL_INT n2 = stackPopINT(pVM->pStack); - FICL_INT n1 = stackPopINT(pVM->pStack); + FICL_INT n2; + FICL_INT n1; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif - stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2); + n2 = POPINT(); + n1 = POPINT(); + + PUSHINT((n1 > n2) ? n1 : n2); return; } static void ficlMin(FICL_VM *pVM) { - FICL_INT n2 = stackPopINT(pVM->pStack); - FICL_INT n1 = stackPopINT(pVM->pStack); + FICL_INT n2; + FICL_INT n1; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,1); +#endif + + n2 = POPINT(); + n1 = POPINT(); - stackPushINT(pVM->pStack, (n1 < n2) ? n1 : n2); + PUSHINT((n1 < n2) ? n1 : n2); return; } @@ -3181,9 +3430,16 @@ static void ficlMin(FICL_VM *pVM) **************************************************************************/ static void move(FICL_VM *pVM) { - FICL_UNS u = stackPopUNS(pVM->pStack); - char *addr2 = stackPopPtr(pVM->pStack); - char *addr1 = stackPopPtr(pVM->pStack); + FICL_UNS u; + char *addr2; + char *addr1; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,3,0); +#endif + + u = POPUNS(); + addr2 = POPPTR(); + addr1 = POPPTR(); if (u == 0) return; @@ -3230,11 +3486,16 @@ static void recurseCoIm(FICL_VM *pVM) **************************************************************************/ static void sToD(FICL_VM *pVM) { - FICL_INT s = stackPopINT(pVM->pStack); + FICL_INT s; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,1,2); +#endif + + s = POPINT(); - /* sign extend to 64 bits.. */ - stackPushINT(pVM->pStack, s); - stackPushINT(pVM->pStack, (s < 0) ? -1 : 0); + /* sign extend to 64 bits.. */ + PUSHINT(s); + PUSHINT((s < 0) ? -1 : 0); return; } @@ -3247,8 +3508,11 @@ static void sToD(FICL_VM *pVM) **************************************************************************/ static void source(FICL_VM *pVM) { - stackPushPtr(pVM->pStack, pVM->tib.cp); - stackPushINT(pVM->pStack, vmGetInBufLen(pVM)); +#if FICL_ROBUST > 1 + vmCheckStack(pVM,0,2); +#endif + PUSHPTR(pVM->tib.cp); + PUSHINT(vmGetInBufLen(pVM)); return; } @@ -3270,261 +3534,10 @@ static void ficlVersion(FICL_VM *pVM) **************************************************************************/ 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); + vmCheckStack(pVM,0,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); + PUSHPTR(&pVM->tib.index); return; } @@ -3546,7 +3559,7 @@ static void colonNoName(FICL_VM *pVM) pVM->state = COMPILE; pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); - stackPushPtr(pVM->pStack, pFW); + PUSHPTR(pFW); markControlTag(pVM, colonTag); return; } @@ -3572,7 +3585,7 @@ static void colonNoName(FICL_VM *pVM) static void userParen(FICL_VM *pVM) { FICL_INT i = pVM->runningWord->param[0].i; - stackPushPtr(pVM->pStack, &pVM->user[i]); + PUSHPTR(&pVM->user[i]); return; } @@ -3621,12 +3634,12 @@ static void toValue(FICL_VM *pVM) dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; } - else if (pFW && pFW->code == do2LocalIm) - { + else if (pFW && pFW->code == do2LocalIm) + { dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen)); dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); return; - } + } } #endif @@ -3643,7 +3656,7 @@ static void toValue(FICL_VM *pVM) pFW->param[0] = stackPop(pVM->pStack); else /* compile code to store to word's param */ { - stackPushPtr(pVM->pStack, &pFW->param[0]); + PUSHPTR(&pFW->param[0]); literalIm(pVM); dictAppendCell(dp, LVALUEtoCELL(pStore)); } @@ -3788,10 +3801,16 @@ static void doLocalIm(FICL_VM *pVM) **************************************************************************/ static void localParen(FICL_VM *pVM) { - FICL_DICT *pDict = ficlGetDict(); - STRINGINFO si; - SI_SETLEN(si, stackPopUNS(pVM->pStack)); - SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); + static CELL *pMark = NULL; + FICL_DICT *pDict; + STRINGINFO si; +#if FICL_ROBUST > 1 + vmCheckStack(pVM,2,0); +#endif + + pDict = ficlGetDict(); + SI_SETLEN(si, POPUNS()); + SI_SETPTR(si, (char *)POPPTR()); if (SI_COUNT(si) > 0) { /* add a local to the **locals** dict and update nLocals */ @@ -3897,7 +3916,7 @@ static void twoLocalParen(FICL_VM *pVM) dictAppendCell(pDict, LVALUEtoCELL(nLocals)); } - dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen)); + dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen)); dictAppendCell(pDict, LVALUEtoCELL(nLocals)); nLocals += 2; @@ -3913,204 +3932,6 @@ static void twoLocalParen(FICL_VM *pVM) #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 ( "<spaces>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! -*/ -static int isAFiclWord(FICL_WORD *pFW) -{ - 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 @@ -4150,7 +3971,7 @@ static void compareString(FICL_VM *pVM) else if (n > 0) n = 1; - stackPushINT(pVM->pStack, n); + PUSHINT(n); return; } @@ -4168,7 +3989,7 @@ static void compareString(FICL_VM *pVM) **************************************************************************/ static void sourceid(FICL_VM *pVM) { - stackPushINT(pVM->pStack, pVM->sourceID.i); + PUSHINT(pVM->sourceID.i); return; } @@ -4188,220 +4009,14 @@ static void sourceid(FICL_VM *pVM) **************************************************************************/ static void refill(FICL_VM *pVM) { - static int tries = 0; - FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; - if (ret && tries == 0) { - tries = 1; + if (ret && (pVM->fRestart == 0)) vmThrow(pVM, VM_RESTART); - } - if (tries == 1) - tries = 0; - stackPushINT(pVM->pStack, ret); - return; -} - - -/************************************************************************** - f o r g e t -** TOOLS EXT ( "<spaces>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 + PUSHINT(ret); 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 @@ -4479,53 +4094,54 @@ static void ficlCatch(FICL_VM *pVM) except = setjmp(vmState); switch (except) - { - /* - ** Setup condition - push poison pill so that the VM throws - ** VM_INNEREXIT if the XT terminates normally, then execute - ** the XT - */ - case 0: - vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */ + { + /* + ** 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; + break; - /* - ** Normal exit from XT - lose the poison pill, - ** restore old setjmp vector and push a zero. - */ - case VM_INNEREXIT: + /* + ** 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: + PUSHINT(0); /* Push 0 -- everything is ok */ + break; + + /* + ** Some other exception got thrown - restore pre-existing VM state + ** and push the exception code + */ + default: /* Restore vm's state */ memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); - stackPushINT(pVM->pStack, except);/* Push error */ - break; - } + PUSHINT(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 - */ - +/************************************************************************** +** t h r o w +** EXCEPTION +** Throw -- From ANS Forth standard. +** +** Throw takes the ToS and, if that's different from zero, +** returns to the last executed catch context. Further throws will +** unstack previously executed "catches", in LIFO mode. +** +** Daniel C. Sobral Jan 09/1999 +**************************************************************************/ static void ficlThrow(FICL_VM *pVM) { int except; @@ -4537,6 +4153,10 @@ static void ficlThrow(FICL_VM *pVM) } +/************************************************************************** +** a l l o c a t e +** MEMORY +**************************************************************************/ static void ansAllocate(FICL_VM *pVM) { size_t size; @@ -4544,24 +4164,32 @@ static void ansAllocate(FICL_VM *pVM) size = stackPopINT(pVM->pStack); p = ficlMalloc(size); - stackPushPtr(pVM->pStack, p); + PUSHPTR(p); if (p) - stackPushINT(pVM->pStack, 0); + PUSHINT(0); else - stackPushINT(pVM->pStack, 1); + PUSHINT(1); } +/************************************************************************** +** f r e e +** MEMORY +**************************************************************************/ static void ansFree(FICL_VM *pVM) { void *p; p = stackPopPtr(pVM->pStack); ficlFree(p); - stackPushINT(pVM->pStack, 0); + PUSHINT(0); } +/************************************************************************** +** r e s i z e +** MEMORY +**************************************************************************/ static void ansResize(FICL_VM *pVM) { size_t size; @@ -4572,29 +4200,21 @@ static void ansResize(FICL_VM *pVM) new = ficlRealloc(old, size); if (new) { - stackPushPtr(pVM->pStack, new); - stackPushINT(pVM->pStack, 0); + PUSHPTR(new); + PUSHINT(0); } else { - stackPushPtr(pVM->pStack, old); - stackPushINT(pVM->pStack, 1); + PUSHPTR(old); + PUSHINT(1); } } -/* -** Retrieves free space remaining on the dictionary -*/ -static void freeHeap(FICL_VM *pVM) -{ - stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict())); -} - -/* -** exit-inner +/************************************************************************** +** e x i t - i n n e r ** Signals execXT that an inner loop has completed -*/ +**************************************************************************/ static void ficlExitInner(FICL_VM *pVM) { vmThrow(pVM, VM_INNEREXIT); @@ -4615,38 +4235,75 @@ static void dnegate(FICL_VM *pVM) return; } -/******************* Increase dictionary size on-demand ******************/ -static void ficlDictThreshold(FICL_VM *pVM) +#if 0 +/************************************************************************** + +** +**************************************************************************/ +static void funcname(FICL_VM *pVM) { - stackPushPtr(pVM->pStack, &dictThreshold); + IGNORE(pVM); + return; } -static void ficlDictIncrease(FICL_VM *pVM) + +#endif +/************************************************************************** + f i c l W o r d C l a s s i f y +** This public function helps to classify word types for SEE +** and the deugger in tools.c. Given an pointer to a word, it returns +** a member of WOR +**************************************************************************/ +WORDKIND ficlWordClassify(FICL_WORD *pFW) { - stackPushPtr(pVM->pStack, &dictIncrease); -} + typedef struct + { + WORDKIND kind; + FICL_CODE code; + } CODEtoKIND; -/************************* freebsd added trace ***************************/ + static CODEtoKIND codeMap[] = + { + {BRANCH, branchParen}, + {COLON, colonParen}, + {CONSTANT, constantParen}, + {CREATE, createParen}, + {DO, doParen}, + {DOES, doDoes}, + {IF, ifParen}, + {LITERAL, literalParen}, + {LOOP, loopParen}, + {PLOOP, plusLoopParen}, + {QDO, qDoParen}, + {STRINGLIT, stringLit}, + {USER, userParen}, + {VARIABLE, variableParen}, + }; + +#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND)) + + FICL_CODE code = pFW->code; + int i; -#ifdef FICL_TRACE -static void ficlTrace(FICL_VM *pVM) -{ -#if FICL_ROBUST > 1 - vmCheckStack(pVM, 1, 1); -#endif + for (i=0; i < nMAP; i++) + { + if (codeMap[i].code == code) + return codeMap[i].kind; + } - ficl_trace = stackPopINT(pVM->pStack); + return PRIMITIVE; } -#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) +void ficlCompileCore(FICL_SYSTEM *pSys) { + FICL_DICT *dp = pSys->dp; assert (dp); /* @@ -4658,7 +4315,7 @@ void ficlCompileCore(FICL_DICT *dp) dictAppendWord(dp, "#", numberSign, FW_DEFAULT); dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); - dictAppendWord(dp, "\'", tick, FW_DEFAULT); + dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT); dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); dictAppendWord(dp, "*", mul, FW_DEFAULT); dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); @@ -4670,7 +4327,6 @@ void ficlCompileCore(FICL_DICT *dp) 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); @@ -4696,7 +4352,7 @@ void ficlCompileCore(FICL_DICT *dp) 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, ">r", toRStack, FW_COMPILE); dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); dictAppendWord(dp, "@", fetch, FW_DEFAULT); dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); @@ -4757,8 +4413,8 @@ void ficlCompileCore(FICL_DICT *dp) 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, "r>", fromRStack, FW_COMPILE); + dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE); dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); dictAppendWord(dp, "rot", rot, FW_DEFAULT); @@ -4793,60 +4449,20 @@ void ficlCompileCore(FICL_DICT *dp) */ dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); + dictAppendWord(dp, "2>r", twoToR, FW_COMPILE); + dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE); + dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE); 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, "source-id", sourceid, FW_DEFAULT); + dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); dictAppendWord(dp, "value", constant, FW_DEFAULT); dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); - /* 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 - dictAppendWord(dp, "setenv", ficlSetenv, FW_DEFAULT); - dictAppendWord(dp, "setenv?", ficlSetenvq, FW_DEFAULT); - dictAppendWord(dp, "getenv", ficlGetenv, FW_DEFAULT); - dictAppendWord(dp, "unsetenv", ficlUnsetenv, FW_DEFAULT); - dictAppendWord(dp, "copyin", ficlCopyin, FW_DEFAULT); - dictAppendWord(dp, "copyout", ficlCopyout, FW_DEFAULT); - dictAppendWord(dp, "findfile", ficlFindfile, FW_DEFAULT); -#ifdef HAVE_PNP - dictAppendWord(dp, "pnpdevices",ficlPnpdevices, FW_DEFAULT); - dictAppendWord(dp, "pnphandlers",ficlPnphandlers, FW_DEFAULT); -#endif - dictAppendWord(dp, "ccall", ficlCcall, FW_DEFAULT); -#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 @@ -4871,6 +4487,7 @@ void ficlCompileCore(FICL_DICT *dp) */ dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); + dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE); dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); @@ -4932,65 +4549,32 @@ void ficlCompileCore(FICL_DICT *dp) /* ** 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); + ficlCompileSearch(pSys); /* ** 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); + ficlCompileTools(pSys); /* ** Ficl extras */ - dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); dictAppendWord(dp, ">name", toName, FW_DEFAULT); + dictAppendWord(dp, "add-parse-step", + addParseStep, FW_DEFAULT); dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compile-only", compileOnly, FW_DEFAULT); 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, "last-word", getLastWord, FW_DEFAULT); + dictAppendWord(dp, "hash", hash, 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, "i@", iFetch, FW_DEFAULT); - dictAppendWord(dp, "i!", iStore, FW_DEFAULT); + dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT); + dictAppendWord(dp, "q!", quadStore, FW_DEFAULT); dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); dictAppendWord(dp, "w!", wStore, FW_DEFAULT); dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); @@ -5001,6 +4585,7 @@ void ficlCompileCore(FICL_DICT *dp) /* ** internal support words */ + dictAppendWord(dp, "(create)", createParen, FW_COMPILE); pExitParen = dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); pSemiParen = @@ -5029,9 +4614,12 @@ void ficlCompileCore(FICL_DICT *dp) dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); + dictAppendWord(dp, "(parse-step)", + parseStepParen, FW_DEFAULT); dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); assert(dictCellsAvail(dp) > 0); + return; } |