From 355b55c28227a3ff8450e881344606a04cd5ac34 Mon Sep 17 00:00:00 2001 From: msmith Date: Fri, 22 Jan 1999 23:52:59 +0000 Subject: Add EXCEPTION word set. Make TIB handling use buffer size to conform with ANS Forth. Add ANS MEMORY-ALLOC word set. See the PRs for extensive details. PR: kern/9412 kern/9442 kern/9514 Submitted by: PRs from Daniel Sobral --- sys/boot/ficl/alpha/sysdep.c | 7 + sys/boot/ficl/alpha/sysdep.h | 1 + sys/boot/ficl/ficl.c | 11 +- sys/boot/ficl/ficl.h | 54 ++++++-- sys/boot/ficl/i386/sysdep.c | 7 + sys/boot/ficl/i386/sysdep.h | 1 + sys/boot/ficl/softwords/softcore.awk | 2 +- sys/boot/ficl/softwords/softcore.fr | 4 +- sys/boot/ficl/sysdep.c | 7 + sys/boot/ficl/sysdep.h | 1 + sys/boot/ficl/testmain.c | 15 +- sys/boot/ficl/vm.c | 25 ++-- sys/boot/ficl/words.c | 262 ++++++++++++++++++++++++++++++++--- 13 files changed, 339 insertions(+), 58 deletions(-) (limited to 'sys') diff --git a/sys/boot/ficl/alpha/sysdep.c b/sys/boot/ficl/alpha/sysdep.c index 84a704d..8d4ed74 100644 --- a/sys/boot/ficl/alpha/sysdep.c +++ b/sys/boot/ficl/alpha/sysdep.c @@ -66,11 +66,17 @@ void *ficlMalloc (size_t size) return malloc(size); } +void *ficlRealloc (void *p, size_t size) +{ + return realloc(p, size); +} + void ficlFree (void *p) { free(p); } +#ifndef TESTMAIN #ifdef __i386__ /* * outb ( port# c -- ) @@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM) stackPushINT32(pVM->pStack,c); } #endif +#endif /* ** Stub function for dictionary access control - does nothing diff --git a/sys/boot/ficl/alpha/sysdep.h b/sys/boot/ficl/alpha/sysdep.h index 4095701..170a690 100644 --- a/sys/boot/ficl/alpha/sysdep.h +++ b/sys/boot/ficl/alpha/sysdep.h @@ -215,6 +215,7 @@ typedef struct struct vm; void ficlTextOut(struct vm *pVM, char *msg, int fNewline); void *ficlMalloc (size_t size); +void *ficlRealloc (void *p, size_t size); void ficlFree (void *p); /* diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c index 3b5885f..f8b13ac 100644 --- a/sys/boot/ficl/ficl.c +++ b/sys/boot/ficl/ficl.c @@ -170,7 +170,7 @@ int ficlBuild(char *name, FICL_CODE code, char flags) ** time to delete the vm, etc -- or you can ignore this ** signal. **************************************************************************/ -int ficlExec(FICL_VM *pVM, char *pText) +int ficlExec(FICL_VM *pVM, char *pText, INT32 size) { int except; FICL_WORD *tempFW; @@ -180,7 +180,7 @@ int ficlExec(FICL_VM *pVM, char *pText) assert(pVM); - vmPushTib(pVM, pText, &saveTib); + vmPushTib(pVM, pText, size, &saveTib); /* ** Save and restore VM's jmp_buf to enable nested calls to ficlExec @@ -237,6 +237,8 @@ int ficlExec(FICL_VM *pVM, char *pText) break; case VM_ERREXIT: + case VM_ABORT: + case VM_ABORTQ: default: /* user defined exit code?? */ if (pVM->state == COMPILE) { @@ -285,8 +287,7 @@ int ficlExecFD(FICL_VM *pVM, int fd) break; continue; } - cp[i] = '\0'; - if ((rval = ficlExec(pVM, cp)) >= VM_ERREXIT) + if ((rval = ficlExec(pVM, cp, i)) >= VM_ERREXIT) { pVM->sourceID = id; vmThrowErr(pVM, "ficlExecFD: Error at line %d", nLine); @@ -298,7 +299,7 @@ int ficlExecFD(FICL_VM *pVM, int fd) ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; - ficlExec(pVM, ""); + ficlExec(pVM, "", 0); pVM->sourceID = id; return rval; diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h index 3fcb32e..7a54df9 100644 --- a/sys/boot/ficl/ficl.h +++ b/sys/boot/ficl/ficl.h @@ -114,6 +114,19 @@ ** 4. Ficl uses the pad in CORE words - this violates the standard, ** but it's cleaner for a multithreaded system. I'll have to make a ** second pad for reference by the word PAD to fix this. +** 5. The whole inner interpreter is screwed up. It ought to be detached +** from ficlExec. Also, it should fall in line with exception +** handling by saving state. (sobral) +** 6. EXCEPTION should be cleaned. Right now, it doubles ficlExec's +** inner interpreter. (sobral) +** 7. colonParen must get the inner interpreter working on it's "case" +** *before* returning, so that it becomes possible to execute them +** inside other definitions without recreating the inner interpreter +** or other such hacks. (sobral) +** 8. We now have EXCEPTION word set. Let's: +** 8.1. Use the appropriate exceptions throughout the code. +** 8.2. Print the error messages at ficlExec, so someone can catch +** them first. (sobral) ** ** F o r M o r e I n f o r m a t i o n ** @@ -153,6 +166,15 @@ /* ** Revision History: +** +** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an +** "end" field, and all words respect this. ficlExec is passed a "size" +** of TIB, as well as vmPushTib. This size is used to calculate the "end" +** of the string, ie, base+size. If the size is not known, pass -1. +** +** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing +** words has been modified to conform to EXCEPTION EXT word set. +** ** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT, ** SEARCH / SEARCH EXT, TOOLS / TOOLS EXT. ** Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD, @@ -292,10 +314,19 @@ typedef struct ** the block of text it's working on and an index to the next ** unconsumed character in the string. Traditionally, this is ** done by a Text Input Buffer, so I've called this struct TIB. +** +** Since this structure also holds the size of the input buffer, +** and since evaluate requires that, let's put the size here. +** The size is stored as an end-pointer because that is what the +** null-terminated string aware functions find most easy to deal +** with. +** Notice, though, that nobody really uses this except evaluate, +** so it might just be moved to FICL_VM instead. (sobral) */ typedef struct { INT32 index; + char *end; char *cp; } TIB; @@ -470,11 +501,13 @@ int wordIsCompileOnly(FICL_WORD *pFW); /* ** Exit codes for vmThrow */ -#define VM_OUTOFTEXT 1 /* hungry - normal exit */ -#define VM_RESTART 2 /* word needs more text to suxcceed - re-run it */ -#define VM_USEREXIT 3 /* user wants to quit */ -#define VM_ERREXIT 4 /* interp found an error */ -#define VM_QUIT 5 /* like errexit, but leave pStack & base alone */ +#define VM_OUTOFTEXT -256 /* hungry - normal exit */ +#define VM_RESTART -257 /* word needs more text to suxcceed - re-run it */ +#define VM_USEREXIT -258 /* user wants to quit */ +#define VM_ERREXIT -259 /* interp found an error */ +#define VM_ABORT -1 /* like errexit -- abort */ +#define VM_ABORTQ -2 /* like errexit -- abort" */ +#define VM_QUIT -56 /* like errexit, but leave pStack & base alone */ void vmBranchRelative(FICL_VM *pVM, int offset); @@ -513,7 +546,7 @@ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells); ** PopTib restores the TIB state given a saved TIB from PushTib ** GetInBuf returns a pointer to the next unused char of the TIB */ -void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib); +void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib); void vmPopTib(FICL_VM *pVM, TIB *pTib); #define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index) #define vmSetTibIndex(pVM, i) (pVM)->tib.index = i @@ -535,7 +568,7 @@ char *ltoa( INT32 value, char *string, int radix ); char *ultoa(UNS32 value, char *string, int radix ); char digit_to_char(int value); char *strrev( char *string ); -char *skipSpace(char *cp); +char *skipSpace(char *cp,char *end); char *caseFold(char *cp); int strincmp(char *cp1, char *cp2, FICL_COUNT count); @@ -677,7 +710,8 @@ void ficlTermSystem(void); ** f i c l E x e c ** Evaluates a block of input text in the context of the ** specified interpreter. Emits any requested output to the -** interpreter's output function +** interpreter's output function. If the size of the input +** is not known, pass -1. ** Execution returns when the text block has been executed, ** or an error occurs. ** Returns one of the VM_XXXX codes defined in ficl.h: @@ -689,10 +723,12 @@ void ficlTermSystem(void); ** to shut down the interpreter. This would be a good ** time to delete the vm, etc -- or you can ignore this ** signal. +** VM_ABORT and VM_ABORTQ are generated by 'abort' and 'abort"' +** commands. ** Preconditions: successful execution of ficlInitSystem, ** Successful creation and init of the VM by ficlNewVM (or equiv) */ -int ficlExec(FICL_VM *pVM, char *pText); +int ficlExec(FICL_VM *pVM, char *pText, INT32 size); /* ** ficlExecFD(FICL_VM *pVM, int fd); diff --git a/sys/boot/ficl/i386/sysdep.c b/sys/boot/ficl/i386/sysdep.c index 84a704d..8d4ed74 100644 --- a/sys/boot/ficl/i386/sysdep.c +++ b/sys/boot/ficl/i386/sysdep.c @@ -66,11 +66,17 @@ void *ficlMalloc (size_t size) return malloc(size); } +void *ficlRealloc (void *p, size_t size) +{ + return realloc(p, size); +} + void ficlFree (void *p) { free(p); } +#ifndef TESTMAIN #ifdef __i386__ /* * outb ( port# c -- ) @@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM) stackPushINT32(pVM->pStack,c); } #endif +#endif /* ** Stub function for dictionary access control - does nothing diff --git a/sys/boot/ficl/i386/sysdep.h b/sys/boot/ficl/i386/sysdep.h index 4095701..170a690 100644 --- a/sys/boot/ficl/i386/sysdep.h +++ b/sys/boot/ficl/i386/sysdep.h @@ -215,6 +215,7 @@ typedef struct struct vm; void ficlTextOut(struct vm *pVM, char *msg, int fNewline); void *ficlMalloc (size_t size); +void *ficlRealloc (void *p, size_t size); void ficlFree (void *p); /* diff --git a/sys/boot/ficl/softwords/softcore.awk b/sys/boot/ficl/softwords/softcore.awk index b182b99..8928db6 100644 --- a/sys/boot/ficl/softwords/softcore.awk +++ b/sys/boot/ficl/softwords/softcore.awk @@ -91,6 +91,6 @@ END \ printf " \"quit \";\n"; printf "\n\nvoid ficlCompileSoftCore(FICL_VM *pVM)\n"; printf "{\n"; - printf " assert(ficlExec(pVM, softWords) != VM_ERREXIT);\n"; + printf " assert(ficlExec(pVM, softWords, -1) != VM_ERREXIT);\n"; printf "}\n"; } diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr index bcc2696..2b11142 100644 --- a/sys/boot/ficl/softwords/softcore.fr +++ b/sys/boot/ficl/softwords/softcore.fr @@ -33,7 +33,9 @@ decimal 32 constant bl postpone if postpone ." postpone cr - postpone abort + -2 + postpone literal + postpone throw postpone endif ; immediate diff --git a/sys/boot/ficl/sysdep.c b/sys/boot/ficl/sysdep.c index 84a704d..8d4ed74 100644 --- a/sys/boot/ficl/sysdep.c +++ b/sys/boot/ficl/sysdep.c @@ -66,11 +66,17 @@ void *ficlMalloc (size_t size) return malloc(size); } +void *ficlRealloc (void *p, size_t size) +{ + return realloc(p, size); +} + void ficlFree (void *p) { free(p); } +#ifndef TESTMAIN #ifdef __i386__ /* * outb ( port# c -- ) @@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM) stackPushINT32(pVM->pStack,c); } #endif +#endif /* ** Stub function for dictionary access control - does nothing diff --git a/sys/boot/ficl/sysdep.h b/sys/boot/ficl/sysdep.h index 4095701..170a690 100644 --- a/sys/boot/ficl/sysdep.h +++ b/sys/boot/ficl/sysdep.h @@ -215,6 +215,7 @@ typedef struct struct vm; void ficlTextOut(struct vm *pVM, char *msg, int fNewline); void *ficlMalloc (size_t size); +void *ficlRealloc (void *p, size_t size); void ficlFree (void *p); /* diff --git a/sys/boot/ficl/testmain.c b/sys/boot/ficl/testmain.c index f7cdc44..bfb7364 100644 --- a/sys/boot/ficl/testmain.c +++ b/sys/boot/ficl/testmain.c @@ -144,11 +144,8 @@ static void ficlLoad(FICL_VM *pVM) if (len <= 0) continue; - if (cp[len] == '\n') - cp[len] = '\0'; - - result = ficlExec(pVM, cp); - if (result >= VM_ERREXIT) + result = ficlExec(pVM, cp, len); + if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT ) { pVM->sourceID = id; fclose(fp); @@ -161,7 +158,7 @@ static void ficlLoad(FICL_VM *pVM) ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; - ficlExec(pVM, ""); + ficlExec(pVM, "", 0); pVM->sourceID = id; fclose(fp); @@ -246,7 +243,7 @@ int main(int argc, char **argv) buildTestInterface(); pVM = ficlNewVM(); - ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit"); + ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit", -1); /* ** load file from cmd line... @@ -254,7 +251,7 @@ int main(int argc, char **argv) if (argc > 1) { sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]); - ficlExec(pVM, in); + ficlExec(pVM, in, -1); } for (;;) @@ -262,7 +259,7 @@ int main(int argc, char **argv) int ret; if (fgets(in, sizeof(in) - 1, stdin) == NULL) break; - ret = ficlExec(pVM, in); + ret = ficlExec(pVM, in, -1); if (ret == VM_USEREXIT) { ficlTermSystem(); diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c index 6852c62..ebdf944 100644 --- a/sys/boot/ficl/vm.c +++ b/sys/boot/ficl/vm.c @@ -156,17 +156,17 @@ STRINGINFO vmGetWord0(FICL_VM *pVM) UNS32 count = 0; char ch; - pSrc = skipSpace(pSrc); + pSrc = skipSpace(pSrc,pVM->tib.end); SI_SETPTR(si, pSrc); - for (ch = *pSrc; ch != '\0' && !isspace(ch); ch = *++pSrc) + for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc) { count++; } SI_SETLEN(si, count); - if (isspace(ch)) /* skip one trailing delimiter */ + if ((pVM->tib.end != pSrc) && isspace(ch)) /* skip one trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); @@ -210,14 +210,15 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim) { STRINGINFO si; char *pSrc = vmGetInBuf(pVM); - char ch; + char ch; - while (*pSrc == delim) /* skip lead delimiters */ + while ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* skip lead delimiters */ pSrc++; SI_SETPTR(si, pSrc); /* mark start of text */ - for (ch = *pSrc; (ch != delim) + for (ch = *pSrc; (pVM->tib.end != pSrc) + && (ch != delim) && (ch != '\0') && (ch != '\r') && (ch != '\n'); ch = *++pSrc) @@ -228,7 +229,7 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim) /* set length of result */ SI_SETLEN(si, pSrc - SI_PTR(si)); - if (*pSrc == delim) /* gobble trailing delimiter */ + if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); @@ -263,7 +264,7 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP) v m P u s h T i b ** Binds the specified input string to the VM and clears >IN (the index) **************************************************************************/ -void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib) +void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib) { if (pSaveTib) { @@ -271,6 +272,7 @@ void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib) } pVM->tib.cp = text; + pVM->tib.end = text + size; pVM->tib.index = 0; } @@ -302,6 +304,7 @@ void vmQuit(FICL_VM *pVM) pVM->runningWord = pInterp; pVM->state = INTERPRET; pVM->tib.cp = NULL; + pVM->tib.end = NULL; pVM->tib.index = 0; pVM->pad[0] = '\0'; pVM->sourceID.i = 0; @@ -551,12 +554,14 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count) s k i p S p a c e ** Given a string pointer, returns a pointer to the first non-space ** char of the string, or to the NULL terminator if no such char found. +** If the pointer reaches "end" first, stop there. If you don't want +** that, pass NULL. **************************************************************************/ -char *skipSpace(char *cp) +char *skipSpace(char *cp, char *end) { assert(cp); - while (isspace(*cp)) + while ((cp != end) && isspace(*cp)) cp++; return cp; diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c index c76c169..d7a420b 100644 --- a/sys/boot/ficl/words.c +++ b/sys/boot/ficl/words.c @@ -880,7 +880,7 @@ static void commentLine(FICL_VM *pVM) char *cp = vmGetInBuf(pVM); char ch = *cp; - while ((ch != '\0') && (ch != '\r') && (ch != '\n')) + while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n')) { ch = *++cp; } @@ -890,11 +890,11 @@ static void commentLine(FICL_VM *pVM) ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, ** and point cp to next char. If EOL is \0, we're done. */ - if (ch != '\0') + if ((pVM->tib.end != cp) && (ch != '\0')) { cp++; - if ( (ch != *cp) + if ( (pVM->tib.end != cp) && (ch != *cp) && ((*cp == '\r') || (*cp == '\n')) ) cp++; } @@ -1180,13 +1180,10 @@ static void interpret(FICL_VM *pVM) // Get next word...if out of text, we're done. */ if (si.count == 0) - { vmThrow(pVM, VM_OUTOFTEXT); - } interpWord(pVM, si); - return; /* back to inner interpreter */ } @@ -1234,7 +1231,6 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si) { vmThrowErr(pVM, "Error: Compile only!"); } - vmExecute(pVM, tempFW); } @@ -2069,13 +2065,13 @@ static void dotParen(FICL_VM *pVM) char *pDest = pVM->pad; char ch; - pSrc = skipSpace(pSrc); + pSrc = skipSpace(pSrc,pVM->tib.end); - for (ch = *pSrc; (ch != '\0') && (ch != ')'); ch = *++pSrc) + for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc) *pDest++ = ch; *pDest = '\0'; - if (ch == ')') + if ((pVM->tib.end != pSrc) && (ch == ')')) pSrc++; vmTextOut(pVM, pVM->pad, 0); @@ -2441,7 +2437,7 @@ static void quit(FICL_VM *pVM) static void ficlAbort(FICL_VM *pVM) { - vmThrow(pVM, VM_ERREXIT); + vmThrow(pVM, VM_ABORT); return; } @@ -2462,6 +2458,10 @@ static void ficlAbort(FICL_VM *pVM) ** Implementation: if there's more text in the TIB, use it. Otherwise ** throw out for more text. Copy characters up to the max count into the ** address given, and return the number of actual characters copied. +** +** This may not strictly violate the standard, but I'm sure any programs +** asking for user input at load time will *not* be expecting this +** behavior. (sobral) **************************************************************************/ static void accept(FICL_VM *pVM) { @@ -2469,7 +2469,7 @@ static void accept(FICL_VM *pVM) char *cp; char *pBuf = vmGetInBuf(pVM); - len = strlen(pBuf); + for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++); if (len == 0) vmThrow(pVM, VM_RESTART); /* OK - now we have something in the text buffer - use it */ @@ -2692,25 +2692,28 @@ static void environmentQ(FICL_VM *pVM) ** EVALUATE CORE ( i*x c-addr u -- j*x ) ** Save the current input source specification. Store minus-one (-1) in ** SOURCE-ID if it is present. Make the string described by c-addr and u -** both the input source and input buffer, set >IN to zero, and interpret. +** both the input source andinput buffer, set >IN to zero, and interpret. ** When the parse area is empty, restore the prior input source ** specification. Other stack effects are due to the words EVALUATEd. ** -** DEFICIENCY: this version does not handle errors or restarts. +** DEFICIENCY: this version does not handle restarts. Also, exceptions +** are just passed ahead. Is this the Right Thing? I don't know... **************************************************************************/ static void evaluate(FICL_VM *pVM) { - UNS32 count = stackPopUNS32(pVM->pStack); + INT32 count = stackPopINT32(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); CELL id; + int result; - IGNORE(count); id = pVM->sourceID; pVM->sourceID.i = -1; vmPushIP(pVM, &pInterpret); - ficlExec(pVM, cp); + result = ficlExec(pVM, cp, count); vmPopIP(pVM); pVM->sourceID = id; + if (result != VM_OUTOFTEXT) + vmThrow(pVM, result); return; } @@ -2843,12 +2846,12 @@ static void parse(FICL_VM *pVM) cp = pSrc; /* mark start of text */ - while ((*pSrc != delim) && (*pSrc != '\0')) + while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0')) pSrc++; /* find next delimiter or end */ count = pSrc - cp; /* set length of result */ - if (*pSrc == delim) /* gobble trailing delimiter */ + if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); @@ -3159,9 +3162,11 @@ static void sToD(FICL_VM *pVM) ** input buffer. **************************************************************************/ static void source(FICL_VM *pVM) -{ +{ int i; + stackPushPtr(pVM->pStack, pVM->tib.cp); - stackPushINT32(pVM->pStack, strlen(pVM->tib.cp)); + for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++); + stackPushINT32(pVM->pStack, i); return; } @@ -4049,6 +4054,194 @@ static void forget(FICL_VM *pVM) return; } +/*************** freebsd added memory-alloc handling words ******************/ + +static void allocate(FICL_VM *pVM) +{ + size_t size; + void *p; + + size = stackPopINT32(pVM->pStack); + p = ficlMalloc(size); + stackPushPtr(pVM->pStack, p); + if (p) + stackPushINT32(pVM->pStack, 0); + else + stackPushINT32(pVM->pStack, 1); +} + +static void free4th(FICL_VM *pVM) +{ + void *p; + + p = stackPopPtr(pVM->pStack); + ficlFree(p); + stackPushINT32(pVM->pStack, 0); +} + +static void resize(FICL_VM *pVM) +{ + size_t size; + void *new, *old; + + size = stackPopINT32(pVM->pStack); + old = stackPopPtr(pVM->pStack); + new = ficlRealloc(old, size); + if (new) { + stackPushPtr(pVM->pStack, new); + stackPushINT32(pVM->pStack, 0); + } else { + stackPushPtr(pVM->pStack, old); + stackPushINT32(pVM->pStack, 1); + } +} + +/***************** freebsd added exception handling words *******************/ + +/* + * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE + * the word in ToS. If an exception happens, restore the state to what + * it was before, and pushes the exception value on the stack. If not, + * push zero. + * + * Notice that Catch implements an inner interpreter. This is ugly, + * but given how ficl works, it cannot be helped. The problem is that + * colon definitions will be executed *after* the function returns, + * while "code" definitions will be executed immediately. I considered + * other solutions to this problem, but all of them shared the same + * basic problem (with added disadvantages): if ficl ever changes it's + * inner thread modus operandi, one would have to fix this word. + * + * More comments can be found throughout catch's code. + * + * BUGS: do not handle locals unnesting correctly... I think... + * + * Daniel C. Sobral Jan 09/1999 + */ + +static void catch(FICL_VM *pVM) +{ + int except; + jmp_buf vmState; + FICL_VM VM; + FICL_STACK pStack; + FICL_STACK rStack; + FICL_WORD *pFW; + IPTYPE exitIP; + + /* + * Get xt. + * We need this *before* we save the stack pointer, or + * we'll have to pop one element out of the stack after + * an exception. I prefer to get done with it up front. :-) + */ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + pFW = stackPopPtr(pVM->pStack); + + /* + * Save vm's state -- a catch will not back out environmental + * changes. + * + * We are *not* saving dictionary state, since it is + * global instead of per vm, and we are not saving + * stack contents, since we are not required to (and, + * thus, it would be useless). We save pVM, and pVM + * "stacks" (a structure containing general information + * about it, including the current stack pointer). + */ + memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); + memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); + memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); + + /* + * Give pVM a jmp_buf + */ + pVM->pState = &vmState; + + /* + * Safety net + */ + except = setjmp(vmState); + + /* + * And now, choose what to do depending on except. + */ + + /* Things having gone wrong... */ + if(except) { + /* Restore vm's state */ + memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); + memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); + memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); + + /* Push error */ + stackPushINT32(pVM->pStack, except); + + /* Things being ok... */ + } else { + /* + * We need to know when to exit the inner loop + * Colonp, the "code" for colon words, just pushes + * the word's IP onto the RP, and expect the inner + * interpreter to do the rest. Well, I'd rather have + * it done *before* I return from this function, + * losing the automatic variables I'm using to save + * state. Sure, I could save this on dynamic memory + * and save state on RP, or I could even implement + * the poor man's version of this word in Forth with + * sp@, sp!, rp@ and rp!, but we have a lot of state + * neatly tucked away in pVM, so why not save it? + */ + exitIP = pVM->ip; + + /* Execute the xt -- inline code for vmExecute */ + + pVM->runningWord = pFW; + pFW->code(pVM); + + /* + * Run the inner loop until we get back to exitIP + */ + for (; pVM->ip != exitIP;) { + pFW = *pVM->ip++; + + /* Inline code for vmExecute */ + pVM->runningWord = pFW; + pFW->code(pVM); + } + + + /* Restore just the setjmp vector */ + pVM->pState = VM.pState; + + /* Push 0 -- everything is ok */ + stackPushINT32(pVM->pStack, 0); + } +} + +/* + * Throw -- maybe vmThow already do what's required, but I don't really + * know what happens when you longjmp(buf, 0). From ANS Forth standard. + * + * Anyway, 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 throw(FICL_VM *pVM) +{ + int except; + + except = stackPopINT32(pVM->pStack); + + if (except) + vmThrow(pVM, except); +} + /************************* freebsd added I/O words **************************/ /* fopen - open a file and return new fd on stack. @@ -4385,14 +4578,37 @@ void ficlCompileCore(FICL_DICT *dp) dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT); dictAppendWord(dp, "ms", ms, FW_DEFAULT); dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT); -#ifdef __i386__ + /* + ** EXCEPTION word set + */ + dictAppendWord(dp, "catch", catch, FW_DEFAULT); + dictAppendWord(dp, "throw", throw, FW_DEFAULT); + + ficlSetEnv("exception", FICL_TRUE); + ficlSetEnv("exception-ext", FICL_TRUE); + + /* + ** MEMORY-ALLOC word set + */ + dictAppendWord(dp, "allocate", allocate, FW_DEFAULT); + dictAppendWord(dp, "free", free4th, FW_DEFAULT); + dictAppendWord(dp, "resize", resize, FW_DEFAULT); + + ficlSetEnv("memory-alloc", FICL_TRUE); + #ifndef TESTMAIN +#ifdef __i386__ dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT); dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT); #endif +#endif + +#if defined(__i386__) ficlSetEnv("arch-i386", FICL_TRUE); -#else + ficlSetEnv("arch-alpha", FICL_FALSE); +#elif defined(__alpha__) ficlSetEnv("arch-i386", FICL_FALSE); + ficlSetEnv("arch-alpha", FICL_TRUE); #endif /* -- cgit v1.1