diff options
Diffstat (limited to 'sys/boot/ficl')
| -rw-r--r-- | sys/boot/ficl/Makefile | 3 | ||||
| -rw-r--r-- | sys/boot/ficl/alpha/sysdep.c | 18 | ||||
| -rw-r--r-- | sys/boot/ficl/alpha/sysdep.h | 92 | ||||
| -rw-r--r-- | sys/boot/ficl/dict.c | 5 | ||||
| -rw-r--r-- | sys/boot/ficl/ficl.c | 233 | ||||
| -rw-r--r-- | sys/boot/ficl/ficl.h | 110 | ||||
| -rw-r--r-- | sys/boot/ficl/i386/sysdep.c | 18 | ||||
| -rw-r--r-- | sys/boot/ficl/i386/sysdep.h | 92 | ||||
| -rw-r--r-- | sys/boot/ficl/math64.c | 342 | ||||
| -rw-r--r-- | sys/boot/ficl/math64.h | 46 | ||||
| -rw-r--r-- | sys/boot/ficl/softwords/ficllocal.fr | 49 | ||||
| -rw-r--r-- | sys/boot/ficl/softwords/ifbrack.fr | 56 | ||||
| -rw-r--r-- | sys/boot/ficl/softwords/softcore.fr | 36 | ||||
| -rw-r--r-- | sys/boot/ficl/stack.c | 10 | ||||
| -rw-r--r-- | sys/boot/ficl/sysdep.c | 18 | ||||
| -rw-r--r-- | sys/boot/ficl/sysdep.h | 92 | ||||
| -rw-r--r-- | sys/boot/ficl/testmain.c | 41 | ||||
| -rw-r--r-- | sys/boot/ficl/vm.c | 112 | ||||
| -rw-r--r-- | sys/boot/ficl/words.c | 931 |
19 files changed, 1488 insertions, 816 deletions
diff --git a/sys/boot/ficl/Makefile b/sys/boot/ficl/Makefile index 5f724bb..9a9dd86 100644 --- a/sys/boot/ficl/Makefile +++ b/sys/boot/ficl/Makefile @@ -9,7 +9,8 @@ SRCS= ${BASE_SRCS} softcore.c CLEANFILES= softcore.c testmain # Standard softwords -SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr +SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr ficllocal.fr \ + ifbrack.fr # Optional OO extension softwords #SOFTWORDS+= oo.fr classes.fr diff --git a/sys/boot/ficl/alpha/sysdep.c b/sys/boot/ficl/alpha/sysdep.c index 8d4ed74..2a5346a 100644 --- a/sys/boot/ficl/alpha/sysdep.c +++ b/sys/boot/ficl/alpha/sysdep.c @@ -7,6 +7,8 @@ ** *******************************************************************/ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdio.h> #include <stdlib.h> @@ -22,9 +24,10 @@ ******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith */ -UNS64 ficlLongMul(UNS32 x, UNS32 y) +#if PORTABLE_LONGMULDIV == 0 +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) { - UNS64 q; + DPUNS q; u_int64_t qx; qx = (u_int64_t)x * (u_int64_t) y; @@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y) return q; } -UNSQR ficlLongDiv(UNS64 q, UNS32 y) +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y) { UNSQR result; u_int64_t qx, qh; @@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y) return result; } +#endif void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline) { @@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); - c=(u_char)stackPopINT32(pVM->pStack); + port=stackPopUNS(pVM->pStack); + c=(u_char)stackPopINT(pVM->pStack); outb(port,c); } @@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); + port=stackPopUNS(pVM->pStack); c=inb(port); - stackPushINT32(pVM->pStack,c); + stackPushINT(pVM->pStack,c); } #endif #endif diff --git a/sys/boot/ficl/alpha/sysdep.h b/sys/boot/ficl/alpha/sysdep.h index 170a690..99ccd58 100644 --- a/sys/boot/ficl/alpha/sysdep.h +++ b/sys/boot/ficl/alpha/sysdep.h @@ -32,6 +32,8 @@ ** send me email at the address above. */ +/* $FreeBSD$ */ + #if !defined (__SYSDEP_H__) #define __SYSDEP_H__ @@ -60,48 +62,75 @@ #endif +/* +** System dependent data type declarations... +*/ #if !defined INT32 -#define INT32 int32_t +#define INT32 long #endif #if !defined UNS32 -#define UNS32 u_int32_t +#define UNS32 unsigned long #endif #if !defined UNS16 -#define UNS16 u_int16_t +#define UNS16 unsigned short #endif #if !defined UNS8 -#define UNS8 u_int8_t +#define UNS8 unsigned char #endif #if !defined NULL #define NULL ((void *)0) #endif +/* +** 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. +*/ +#if !defined FICL_INT +#define FICL_INT INT32 +#endif + +#if !defined FICL_UNS +#define FICL_UNS UNS32 +#endif + +/* +** Ficl presently supports values of 32 and 64 for BITS_PER_CELL +*/ +#if !defined BITS_PER_CELL +#define BITS_PER_CELL 32 +#endif + +#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64)) + Error! +#endif + typedef struct { - UNS32 hi; - UNS32 lo; -} UNS64; + FICL_UNS hi; + FICL_UNS lo; +} DPUNS; typedef struct { - UNS32 quot; - UNS32 rem; + FICL_UNS quot; + FICL_UNS rem; } UNSQR; typedef struct { - INT32 hi; - INT32 lo; -} INT64; + FICL_INT hi; + FICL_INT lo; +} DPINT; typedef struct { - INT32 quot; - INT32 rem; + FICL_INT quot; + FICL_INT rem; } INTQR; @@ -115,6 +144,30 @@ typedef struct #endif /* +** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be +** defined in C in sysdep.c. Use this if you cannot easily +** generate an inline asm definition +*/ +#if !defined (PORTABLE_LONGMULDIV) +#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 +** chokes with an internal compiler error on the function version. +** in release mode. Sheesh. +*/ +#if !defined INLINE_INNER_LOOP +#if defined _DEBUG +#define INLINE_INNER_LOOP 0 +#else +#define INLINE_INNER_LOOP 1 +#endif +#endif + +/* ** FICL_ROBUST enables bounds checking of stacks and the dictionary. ** This will detect stack over and underflows and dictionary overflows. ** Any exceptional condition will result in an assertion failure. @@ -192,7 +245,7 @@ typedef struct ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture ** of the target system; 2 is safe on any 16 or 32 bit -** machine. +** machine. 3 would be appropriate for a 64 bit machine. */ #if !defined FICL_ALIGN #define FICL_ALIGN 2 @@ -215,9 +268,8 @@ 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); - +void *ficlRealloc(void *p, size_t size); /* ** Stub function for dictionary access control - does nothing ** by default, user can redefine to guarantee exclusive dict @@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock); /* ** 64 bit integer math support routines: multiply two UNS32s -** to get a 64 bit prodict, & divide the product by an UNS32 +** to get a 64 bit product, & divide the product by an UNS32 ** to get an UNS32 quotient and remainder. Much easier in asm ** on a 32 bit CPU than in C, which usually doesn't support ** the double length result (but it should). */ -UNS64 ficlLongMul(UNS32 x, UNS32 y); -UNSQR ficlLongDiv(UNS64 q, UNS32 y); +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/dict.c b/sys/boot/ficl/dict.c index 5b45a87..52858b7 100644 --- a/sys/boot/ficl/dict.c +++ b/sys/boot/ficl/dict.c @@ -17,6 +17,8 @@ ** 29 jun 1998 (sadler) added variable sized hash table support */ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdio.h> #include <stdlib.h> @@ -197,7 +199,6 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict, UNS8 flags) { FICL_COUNT len = (FICL_COUNT)SI_COUNT(si); - char *name = SI_PTR(si); char *pName; FICL_WORD *pFW; @@ -232,7 +233,7 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict, d i c t A p p e n d U N S 3 2 ** Append the specified UNS32 to the dictionary **************************************************************************/ -void dictAppendUNS32(FICL_DICT *pDict, UNS32 u) +void dictAppendUNS(FICL_DICT *pDict, UNS32 u) { *pDict->here++ = LVALUEtoCELL(u); return; diff --git a/sys/boot/ficl/ficl.c b/sys/boot/ficl/ficl.c index 9274c1b..ad776be 100644 --- a/sys/boot/ficl/ficl.c +++ b/sys/boot/ficl/ficl.c @@ -21,6 +21,8 @@ ** Code is written in ANSI C for portability. */ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdlib.h> #else @@ -174,20 +176,30 @@ 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, INT32 size) +int ficlExec(FICL_VM *pVM, char *pText) { -#ifdef FICL_TRACE - extern int isAFiclWord(FICL_WORD *pFW); -#endif + return ficlExecC(pVM, pText, -1); +} + +int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size) +{ + static FICL_WORD *pInterp = NULL; + int except; - FICL_WORD *tempFW; jmp_buf vmState; TIB saveTib; FICL_VM VM; FICL_STACK rStack; + if (!pInterp) + pInterp = ficlLookup("interpret"); + + assert(pInterp); assert(pVM); + if (size < 0) + size = strlen(pText); + vmPushTib(pVM, pText, size, &saveTib); /* @@ -207,106 +219,12 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size) pVM->fRestart = 0; pVM->runningWord->code(pVM); } - - /* - ** the mysterious inner interpreter... - ** vmThrow gets you out of this loop with a longjmp() - */ - for (;;) - { -#ifdef FICL_TRACE - CELL c; - char buffer[40]; -#endif - tempFW = *pVM->ip++; -#ifdef FICL_TRACE - if (ficl_trace && isAFiclWord(tempFW)) - { - extern void literalParen(FICL_VM*); - extern void stringLit(FICL_VM*); - extern void ifParen(FICL_VM*); - extern void branchParen(FICL_VM*); - extern void qDoParen(FICL_VM*); - extern void doParen(FICL_VM*); - extern void loopParen(FICL_VM*); - extern void plusLoopParen(FICL_VM*); - - if (tempFW->code == literalParen) - { - c = *PTRtoCELL(pVM->ip); - if (isAFiclWord(c.p)) - { - FICL_WORD *pLit = (FICL_WORD *)c.p; - sprintf(buffer, " literal %.*s (%#lx)", - pLit->nName, pLit->name, c.u); - } - else - sprintf(buffer, " literal %ld (%#lx)", c.i, c.u); - } - else if (tempFW->code == stringLit) - { - FICL_STRING *sp = PTRtoSTRING(pVM->ip); - sprintf(buffer, " s\" %.*s\"", sp->count, sp->text); - } - else if (tempFW->code == ifParen) - { - c = *PTRtoCELL(pVM->ip); - if (c.i > 0) - sprintf(buffer, " if / while (branch rel %ld)", c.i); - else - sprintf(buffer, " until (branch rel %ld)", c.i); - } - else if (tempFW->code == branchParen) - { - c = *PTRtoCELL(pVM->ip); - if (c.i > 0) - sprintf(buffer, " else (branch rel %ld)", c.i); - else - sprintf(buffer, " repeat (branch rel %ld)", c.i); - } - else if (tempFW->code == qDoParen) - { - c = *PTRtoCELL(pVM->ip); - sprintf(buffer, " ?do (leave abs %#lx)", c.u); - } - else if (tempFW->code == doParen) - { - c = *PTRtoCELL(pVM->ip); - sprintf(buffer, " do (leave abs %#lx)", c.u); - } - else if (tempFW->code == loopParen) - { - c = *PTRtoCELL(pVM->ip); - sprintf(buffer, " loop (branch rel %ld)", c.i); - } - else if (tempFW->code == plusLoopParen) - { - c = *PTRtoCELL(pVM->ip); - sprintf(buffer, " +loop (branch rel %ld)", c.i); - } - else /* default: print word's name */ - { - sprintf(buffer, " %.*s", tempFW->nName, tempFW->name); - } - - vmTextOut(pVM, buffer, 1); - } - else if (ficl_trace) /* probably not a word - * - punt and print value - */ - { - sprintf(buffer, " %ld (%#lx)", (PTRtoCELL(pVM->ip))->i, (PTRtoCELL(pVM->ip))->u); - vmTextOut(pVM, buffer, 1); - } -#endif FICL_TRACE - /* - ** inline code for - ** vmExecute(pVM, tempFW); - */ - pVM->runningWord = tempFW; - tempFW->code(pVM); + else + { /* set VM up to interpret text */ + vmPushIP(pVM, &pInterp); } + vmInnerLoop(pVM); break; case VM_RESTART: @@ -315,6 +233,7 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size) break; case VM_OUTOFTEXT: + vmPopIP(pVM); #ifdef TESTMAIN if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0)) ficlTextOut(pVM, FICL_PROMPT, 0); @@ -322,14 +241,18 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size) break; case VM_USEREXIT: + case VM_INNEREXIT: break; case VM_QUIT: if (pVM->state == COMPILE) + { dictAbortDefinition(dp); - - memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); - memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); +#if FICL_WANT_LOCALS + dictEmpty(localp, localp->pForthWords->size); +#endif + } + vmQuit(pVM); break; case VM_ERREXIT: @@ -386,7 +309,7 @@ int ficlExecFD(FICL_VM *pVM, int fd) break; continue; } - rval = ficlExec(pVM, cp, i); + rval = ficlExecC(pVM, cp, i); if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT) { pVM->sourceID = id; @@ -398,13 +321,86 @@ int ficlExecFD(FICL_VM *pVM, int fd) ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; - ficlExec(pVM, "", 0); + ficlExec(pVM, ""); pVM->sourceID = id; return rval; } /************************************************************************** + f i c l E x e c X T +** Given a pointer to a FICL_WORD, push an inner interpreter and +** execute the word to completion. This is in contrast with vmExecute, +** which does not guarantee that the word will have completed when +** the function returns (ie in the case of colon definitions, which +** need an inner interpreter to finish) +** +** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal +** exit condition is VM_INNEREXIT, ficl's private signal to exit the +** inner loop under normal circumstances. If another code is thrown to +** exit the loop, this function will re-throw it if it's nested under +** itself or ficlExec. +** +** NOTE: this function is intended so that C code can execute ficlWords +** given their address in the dictionary (xt). +**************************************************************************/ +int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord) +{ + static FICL_WORD *pQuit = NULL; + int except; + jmp_buf vmState; + jmp_buf *oldState; + + if (!pQuit) + pQuit = ficlLookup("exit-inner"); + + assert(pVM); + assert(pQuit); + + /* + ** Save and restore VM's jmp_buf to enable nested calls + */ + oldState = pVM->pState; + pVM->pState = &vmState; /* This has to come before the setjmp! */ + except = setjmp(vmState); + + if (except) + vmPopIP(pVM); + else + vmPushIP(pVM, &pQuit); + + switch (except) + { + case 0: + vmExecute(pVM, pWord); + vmInnerLoop(pVM); + break; + + case VM_INNEREXIT: + break; + + case VM_RESTART: + case VM_OUTOFTEXT: + case VM_USEREXIT: + case VM_QUIT: + case VM_ERREXIT: + case VM_ABORT: + case VM_ABORTQ: + default: /* user defined exit code?? */ + if (oldState) + { + pVM->pState = oldState; + vmThrow(pVM, except); + } + break; + } + + pVM->pState = oldState; + return (except); +} + + +/************************************************************************** f i c l L o o k u p ** Look in the system dictionary for a match to the given name. If ** found, return the address of the corresponding FICL_WORD. Otherwise @@ -443,7 +439,7 @@ FICL_DICT *ficlGetEnv(void) ** Create an environment variable with a one-CELL payload. ficlSetEnvD ** makes one with a two-CELL payload. **************************************************************************/ -void ficlSetEnv(char *name, UNS32 value) +void ficlSetEnv(char *name, FICL_UNS value) { STRINGINFO si; FICL_WORD *pFW; @@ -464,7 +460,7 @@ void ficlSetEnv(char *name, UNS32 value) return; } -void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo) +void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo) { FICL_WORD *pFW; STRINGINFO si; @@ -500,6 +496,23 @@ FICL_DICT *ficlGetLoc(void) #endif + +/************************************************************************** + f i c l S e t S t a c k S i z e +** Set the stack sizes (return and parameter) to be used for all +** subsequently created VMs. Returns actual stack size to be used. +**************************************************************************/ +int ficlSetStackSize(int nStackCells) +{ + if (nStackCells >= FICL_DEFAULT_STACK) + defaultStack = nStackCells; + else + defaultStack = FICL_DEFAULT_STACK; + + return defaultStack; +} + + /************************************************************************** f i c l T e r m S y s t e m ** Tear the system down by deleting the dictionaries and all VMs. diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h index e0536e6..15bf58a 100644 --- a/sys/boot/ficl/ficl.h +++ b/sys/boot/ficl/ficl.h @@ -27,6 +27,8 @@ ** send me email at the address above. */ +/* $FreeBSD$ */ + #if !defined (__FICL_H__) #define __FICL_H__ /* @@ -114,19 +116,6 @@ ** 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 ** @@ -166,7 +155,9 @@ /* ** Revision History: -** +** +** 15 Apr 1999 (sadler) Merged FreeBSD changes for exception wordset and +** counted strings in ficlExec. ** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an ** "end" field, and all words respect this. ficlExec is passed a "size" ** of TIB, as well as vmPushTib. This size is used to calculate the "end" @@ -228,9 +219,9 @@ struct ficl_dict; /* ** the Good Stuff starts here... */ -#define FICL_VER "2.02" -#ifndef FICL_PROMPT -# define FICL_PROMPT "ok> " +#define FICL_VER "2.03" +#if !defined (FICL_PROMPT) +#define FICL_PROMPT "ok> " #endif /* @@ -245,13 +236,13 @@ struct ficl_dict; /* ** A CELL is the main storage type. It must be large enough -** to contain a pointer or a scalar. Let's be picky and make -** a 32 bit cell explicitly... +** to contain a pointer or a scalar. In order to accommodate +** 32 bit and 64 bit processors, use abstract types for i and u. */ typedef union _cell { - INT32 i; - UNS32 u; + FICL_INT i; + FICL_UNS u; void *p; } CELL; @@ -342,7 +333,7 @@ typedef struct */ typedef struct _ficlStack { - UNS32 nCells; /* size of the stack */ + 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 */ @@ -361,12 +352,12 @@ void stackLink (FICL_STACK *pStack, int nCells); void stackPick (FICL_STACK *pStack, int n); CELL stackPop (FICL_STACK *pStack); void *stackPopPtr (FICL_STACK *pStack); -UNS32 stackPopUNS32 (FICL_STACK *pStack); -INT32 stackPopINT32 (FICL_STACK *pStack); +FICL_UNS stackPopUNS(FICL_STACK *pStack); +FICL_INT stackPopINT(FICL_STACK *pStack); void stackPush (FICL_STACK *pStack, CELL c); void stackPushPtr (FICL_STACK *pStack, void *ptr); -void stackPushUNS32(FICL_STACK *pStack, UNS32 u); -void stackPushINT32(FICL_STACK *pStack, INT32 i); +void stackPushUNS(FICL_STACK *pStack, FICL_UNS u); +void stackPushINT(FICL_STACK *pStack, FICL_INT i); void stackReset (FICL_STACK *pStack); void stackRoll (FICL_STACK *pStack, int n); void stackSetTop(FICL_STACK *pStack, CELL c); @@ -459,6 +450,12 @@ typedef struct vm */ typedef void (*FICL_CODE)(FICL_VM *pVm); +#if 0 +#define VM_ASSERT(pVM) assert((*(pVM->ip - 1)) == pVM->runningWord) +#else +#define VM_ASSERT(pVM) +#endif + /* ** Ficl models memory as a contiguous space divided into ** words in a linked list called the dictionary. @@ -501,10 +498,11 @@ int wordIsCompileOnly(FICL_WORD *pFW); /* ** Exit codes for vmThrow */ -#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_INNEREXIT -256 /* tell ficlExecXT to exit inner loop */ +#define VM_OUTOFTEXT -257 /* hungry - normal exit */ +#define VM_RESTART -258 /* word needs more text to succeed - re-run it */ +#define VM_USEREXIT -259 /* user wants to quit */ +#define VM_ERREXIT -260 /* interp found an error */ #define VM_ABORT -1 /* like errexit -- abort */ #define VM_ABORTQ -2 /* like errexit -- abort" */ #define VM_QUIT -56 /* like errexit, but leave pStack & base alone */ @@ -528,6 +526,28 @@ void vmTextOut(FICL_VM *pVM, char *text, int fNewline); void vmThrow (FICL_VM *pVM, int except); void vmThrowErr(FICL_VM *pVM, char *fmt, ...); +#define vmGetRunningWord(pVM) ((pVM)->runningWord) + + +/* +** The inner interpreter - coded as a macro (see note for +** INLINE_INNER_LOOP in sysdep.h for complaints about VC++ 5 +*/ +#define M_INNER_LOOP(pVM) \ + for (;;) \ + { \ + FICL_WORD *tempFW = *(pVM)->ip++; \ + (pVM)->runningWord = tempFW; \ + tempFW->code(pVM); \ + } + + +#if INLINE_INNER_LOOP != 0 +#define vmInnerLoop(pVM) M_INNER_LOOP(pVM) +#else +void vmInnerLoop(FICL_VM *pVM); +#endif + /* ** vmCheckStack needs a vm pointer because it might have to say ** something if it finds a problem. Parms popCells and pushCells @@ -546,9 +566,11 @@ 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, INT32 size, TIB *pSaveTib); +void vmPushTib(FICL_VM *pVM, char *text, INT32 nChars, TIB *pSaveTib); void vmPopTib(FICL_VM *pVM, TIB *pTib); #define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index) +#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp) +#define vmGetInBufEnd(pVM) ((pVM)->tib.end) #define vmSetTibIndex(pVM, i) (pVM)->tib.index = i #define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp @@ -564,11 +586,13 @@ void vmPopTib(FICL_VM *pVM, TIB *pTib); #pragma warning(disable: 4273) #endif -char *ltoa( INT32 value, char *string, int radix ); -char *ultoa(UNS32 value, char *string, int radix ); +int isPowerOfTwo(FICL_UNS u); + +char *ltoa( FICL_INT value, char *string, int radix ); +char *ultoa(FICL_UNS value, char *string, int radix ); char digit_to_char(int value); char *strrev( char *string ); -char *skipSpace(char *cp,char *end); +char *skipSpace(char *cp, char *end); char *caseFold(char *cp); int strincmp(char *cp1, char *cp2, FICL_COUNT count); @@ -583,7 +607,7 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count); ** A WORDLIST (see the search order word set in DPANS) is ** just a pointer to a FICL_HASH in this implementation. */ -#if !defined HASHSIZE /* Default size of hash table. For best */ +#if !defined HASHSIZE /* Default size of hash table. For most uniform */ #define HASHSIZE 127 /* performance, use a prime number! */ #endif @@ -660,7 +684,7 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict, STRINGINFO si, FICL_CODE pCode, UNS8 flags); -void dictAppendUNS32(FICL_DICT *pDict, UNS32 u); +void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u); int dictCellsAvail(FICL_DICT *pDict); int dictCellsUsed (FICL_DICT *pDict); void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells); @@ -709,8 +733,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. If the size of the input -** is not known, pass -1. +** interpreter's output function. If the input string is NULL +** terminated, you can pass -1 as nChars rather than count it. ** Execution returns when the text block has been executed, ** or an error occurs. ** Returns one of the VM_XXXX codes defined in ficl.h: @@ -727,7 +751,9 @@ void ficlTermSystem(void); ** Preconditions: successful execution of ficlInitSystem, ** Successful creation and init of the VM by ficlNewVM (or equiv) */ -int ficlExec(FICL_VM *pVM, char *pText, INT32 size); +int ficlExec (FICL_VM *pVM, char *pText); +int ficlExecC(FICL_VM *pVM, char *pText, INT32 nChars); +int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord); /* ** ficlExecFD(FICL_VM *pVM, int fd); @@ -746,6 +772,12 @@ int ficlExecFD(FICL_VM *pVM, int fd); FICL_VM *ficlNewVM(void); /* +** Set the stack sizes (return and parameter) to be used for all +** subsequently created VMs. Returns actual stack size to be used. +*/ +int ficlSetStackSize(int nStackCells); + +/* ** Returns the address of the most recently defined word in the system ** dictionary with the given name, or NULL if no match. ** Precondition: successful execution of ficlInitSystem diff --git a/sys/boot/ficl/i386/sysdep.c b/sys/boot/ficl/i386/sysdep.c index 8d4ed74..2a5346a 100644 --- a/sys/boot/ficl/i386/sysdep.c +++ b/sys/boot/ficl/i386/sysdep.c @@ -7,6 +7,8 @@ ** *******************************************************************/ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdio.h> #include <stdlib.h> @@ -22,9 +24,10 @@ ******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith */ -UNS64 ficlLongMul(UNS32 x, UNS32 y) +#if PORTABLE_LONGMULDIV == 0 +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) { - UNS64 q; + DPUNS q; u_int64_t qx; qx = (u_int64_t)x * (u_int64_t) y; @@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y) return q; } -UNSQR ficlLongDiv(UNS64 q, UNS32 y) +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y) { UNSQR result; u_int64_t qx, qh; @@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y) return result; } +#endif void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline) { @@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); - c=(u_char)stackPopINT32(pVM->pStack); + port=stackPopUNS(pVM->pStack); + c=(u_char)stackPopINT(pVM->pStack); outb(port,c); } @@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); + port=stackPopUNS(pVM->pStack); c=inb(port); - stackPushINT32(pVM->pStack,c); + stackPushINT(pVM->pStack,c); } #endif #endif diff --git a/sys/boot/ficl/i386/sysdep.h b/sys/boot/ficl/i386/sysdep.h index 170a690..99ccd58 100644 --- a/sys/boot/ficl/i386/sysdep.h +++ b/sys/boot/ficl/i386/sysdep.h @@ -32,6 +32,8 @@ ** send me email at the address above. */ +/* $FreeBSD$ */ + #if !defined (__SYSDEP_H__) #define __SYSDEP_H__ @@ -60,48 +62,75 @@ #endif +/* +** System dependent data type declarations... +*/ #if !defined INT32 -#define INT32 int32_t +#define INT32 long #endif #if !defined UNS32 -#define UNS32 u_int32_t +#define UNS32 unsigned long #endif #if !defined UNS16 -#define UNS16 u_int16_t +#define UNS16 unsigned short #endif #if !defined UNS8 -#define UNS8 u_int8_t +#define UNS8 unsigned char #endif #if !defined NULL #define NULL ((void *)0) #endif +/* +** 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. +*/ +#if !defined FICL_INT +#define FICL_INT INT32 +#endif + +#if !defined FICL_UNS +#define FICL_UNS UNS32 +#endif + +/* +** Ficl presently supports values of 32 and 64 for BITS_PER_CELL +*/ +#if !defined BITS_PER_CELL +#define BITS_PER_CELL 32 +#endif + +#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64)) + Error! +#endif + typedef struct { - UNS32 hi; - UNS32 lo; -} UNS64; + FICL_UNS hi; + FICL_UNS lo; +} DPUNS; typedef struct { - UNS32 quot; - UNS32 rem; + FICL_UNS quot; + FICL_UNS rem; } UNSQR; typedef struct { - INT32 hi; - INT32 lo; -} INT64; + FICL_INT hi; + FICL_INT lo; +} DPINT; typedef struct { - INT32 quot; - INT32 rem; + FICL_INT quot; + FICL_INT rem; } INTQR; @@ -115,6 +144,30 @@ typedef struct #endif /* +** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be +** defined in C in sysdep.c. Use this if you cannot easily +** generate an inline asm definition +*/ +#if !defined (PORTABLE_LONGMULDIV) +#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 +** chokes with an internal compiler error on the function version. +** in release mode. Sheesh. +*/ +#if !defined INLINE_INNER_LOOP +#if defined _DEBUG +#define INLINE_INNER_LOOP 0 +#else +#define INLINE_INNER_LOOP 1 +#endif +#endif + +/* ** FICL_ROBUST enables bounds checking of stacks and the dictionary. ** This will detect stack over and underflows and dictionary overflows. ** Any exceptional condition will result in an assertion failure. @@ -192,7 +245,7 @@ typedef struct ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture ** of the target system; 2 is safe on any 16 or 32 bit -** machine. +** machine. 3 would be appropriate for a 64 bit machine. */ #if !defined FICL_ALIGN #define FICL_ALIGN 2 @@ -215,9 +268,8 @@ 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); - +void *ficlRealloc(void *p, size_t size); /* ** Stub function for dictionary access control - does nothing ** by default, user can redefine to guarantee exclusive dict @@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock); /* ** 64 bit integer math support routines: multiply two UNS32s -** to get a 64 bit prodict, & divide the product by an UNS32 +** to get a 64 bit product, & divide the product by an UNS32 ** to get an UNS32 quotient and remainder. Much easier in asm ** on a 32 bit CPU than in C, which usually doesn't support ** the double length result (but it should). */ -UNS64 ficlLongMul(UNS32 x, UNS32 y); -UNSQR ficlLongDiv(UNS64 q, UNS32 y); +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/math64.c b/sys/boot/ficl/math64.c index e83000a..e3d64e8 100644 --- a/sys/boot/ficl/math64.c +++ b/sys/boot/ficl/math64.c @@ -3,18 +3,21 @@ ** Forth Inspired Command Language - 64 bit math support routines ** Author: John Sadler (john_sadler@alum.mit.edu) ** Created: 25 January 1998 -** +** Rev 2.03: Support for 128 bit DP math. This file really ouught to +** be renamed! *******************************************************************/ +/* $FreeBSD$ */ + #include "ficl.h" #include "math64.h" /************************************************************************** m 6 4 A b s -** Returns the absolute value of an INT64 +** Returns the absolute value of an DPINT **************************************************************************/ -INT64 m64Abs(INT64 x) +DPINT m64Abs(DPINT x) { if (m64IsNegative(x)) x = m64Negate(x); @@ -51,7 +54,7 @@ INT64 m64Abs(INT64 x) ** 10 -7 3 -1 ** -10 -7 -3 1 **************************************************************************/ -INTQR m64FlooredDivI(INT64 num, INT32 den) +INTQR m64FlooredDivI(DPINT num, FICL_INT den) { INTQR qr; UNSQR uqr; @@ -71,7 +74,7 @@ INTQR m64FlooredDivI(INT64 num, INT32 den) signQuot = -signQuot; } - uqr = ficlLongDiv(m64CastIU(num), (UNS32)den); + uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den); qr = m64CastQRUI(uqr); if (signQuot < 0) { @@ -92,9 +95,9 @@ INTQR m64FlooredDivI(INT64 num, INT32 den) /************************************************************************** m 6 4 I s N e g a t i v e -** Returns TRUE if the specified INT64 has its sign bit set. +** Returns TRUE if the specified DPINT has its sign bit set. **************************************************************************/ -int m64IsNegative(INT64 x) +int m64IsNegative(DPINT x) { return (x.hi < 0); } @@ -103,15 +106,15 @@ int m64IsNegative(INT64 x) /************************************************************************** m 6 4 M a c ** Mixed precision multiply and accumulate primitive for number building. -** Multiplies UNS64 u by UNS32 mul and adds UNS32 add. Mul is typically +** Multiplies DPUNS u by FICL_UNS mul and adds FICL_UNS add. Mul is typically ** the numeric base, and add represents a digit to be appended to the ** growing number. ** Returns the result of the operation **************************************************************************/ -UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add) +DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add) { - UNS64 resultLo = ficlLongMul(u.lo, mul); - UNS64 resultHi = ficlLongMul(u.hi, mul); + DPUNS resultLo = ficlLongMul(u.lo, mul); + DPUNS resultHi = ficlLongMul(u.hi, mul); resultLo.hi += resultHi.lo; resultHi.lo = resultLo.lo + add; @@ -126,11 +129,11 @@ UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add) /************************************************************************** m 6 4 M u l I -** Multiplies a pair of INT32s and returns an INT64 result. +** Multiplies a pair of FICL_INTs and returns an DPINT result. **************************************************************************/ -INT64 m64MulI(INT32 x, INT32 y) +DPINT m64MulI(FICL_INT x, FICL_INT y) { - UNS64 prod; + DPUNS prod; int sign = 1; if (x < 0) @@ -155,9 +158,9 @@ INT64 m64MulI(INT32 x, INT32 y) /************************************************************************** m 6 4 N e g a t e -** Negates an INT64 by complementing and incrementing. +** Negates an DPINT by complementing and incrementing. **************************************************************************/ -INT64 m64Negate(INT64 x) +DPINT m64Negate(DPINT x) { x.hi = ~x.hi; x.lo = ~x.lo; @@ -171,56 +174,56 @@ INT64 m64Negate(INT64 x) /************************************************************************** m 6 4 P u s h -** Push an INT64 onto the specified stack in the order required +** Push an DPINT onto the specified stack in the order required ** by ANS Forth (most significant cell on top) ** These should probably be macros... **************************************************************************/ -void i64Push(FICL_STACK *pStack, INT64 i64) +void i64Push(FICL_STACK *pStack, DPINT i64) { - stackPushINT32(pStack, i64.lo); - stackPushINT32(pStack, i64.hi); + stackPushINT(pStack, i64.lo); + stackPushINT(pStack, i64.hi); return; } -void u64Push(FICL_STACK *pStack, UNS64 u64) +void u64Push(FICL_STACK *pStack, DPUNS u64) { - stackPushINT32(pStack, u64.lo); - stackPushINT32(pStack, u64.hi); + stackPushINT(pStack, u64.lo); + stackPushINT(pStack, u64.hi); return; } /************************************************************************** m 6 4 P o p -** Pops an INT64 off the stack in the order required by ANS Forth +** Pops an DPINT off the stack in the order required by ANS Forth ** (most significant cell on top) ** These should probably be macros... **************************************************************************/ -INT64 i64Pop(FICL_STACK *pStack) +DPINT i64Pop(FICL_STACK *pStack) { - INT64 ret; - ret.hi = stackPopINT32(pStack); - ret.lo = stackPopINT32(pStack); + DPINT ret; + ret.hi = stackPopINT(pStack); + ret.lo = stackPopINT(pStack); return ret; } -UNS64 u64Pop(FICL_STACK *pStack) +DPUNS u64Pop(FICL_STACK *pStack) { - UNS64 ret; - ret.hi = stackPopINT32(pStack); - ret.lo = stackPopINT32(pStack); + DPUNS ret; + ret.hi = stackPopINT(pStack); + ret.lo = stackPopINT(pStack); return ret; } /************************************************************************** m 6 4 S y m m e t r i c D i v -** Divide an INT64 by an INT32 and return an INT32 quotient and an INT32 -** remainder. The absolute values of quotient and remainder are not +** Divide an DPINT by a FICL_INT and return a FICL_INT quotient and a +** FICL_INT remainder. The absolute values of quotient and remainder are not ** affected by the signs of the numerator and denominator (the operation ** is symmetric on the number line) **************************************************************************/ -INTQR m64SymmetricDivI(INT64 num, INT32 den) +INTQR m64SymmetricDivI(DPINT num, FICL_INT den) { INTQR qr; UNSQR uqr; @@ -240,7 +243,7 @@ INTQR m64SymmetricDivI(INT64 num, INT32 den) signQuot = -signQuot; } - uqr = ficlLongDiv(m64CastIU(num), (UNS32)den); + uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den); qr = m64CastQRUI(uqr); if (signRem < 0) qr.rem = -qr.rem; @@ -254,39 +257,51 @@ INTQR m64SymmetricDivI(INT64 num, INT32 den) /************************************************************************** m 6 4 U M o d -** Divides an UNS64 by base (an UNS16) and returns an UNS16 remainder. -** Writes the quotient back to the original UNS64 as a side effect. -** This operation is typically used to convert an UNS64 to a text string +** Divides a DPUNS by base (an UNS16) and returns an UNS16 remainder. +** Writes the quotient back to the original DPUNS as a side effect. +** This operation is typically used to convert an DPUNS to a text string ** in any base. See words.c:numberSignS, for example. ** Mechanics: performs 4 ficlLongDivs, each of which produces 16 bits -** of the quotient. C does not provide a way to divide an UNS32 by an -** UNS16 and get an UNS32 quotient (ldiv is closest, but it's signed, +** of the quotient. C does not provide a way to divide an FICL_UNS by an +** UNS16 and get an FICL_UNS quotient (ldiv is closest, but it's signed, ** unfortunately), so I've used ficlLongDiv. **************************************************************************/ -UNS16 m64UMod(UNS64 *pUD, UNS16 base) +#if (BITS_PER_CELL == 32) + +#define UMOD_SHIFT 16 +#define UMOD_MASK 0x0000ffff + +#elif (BITS_PER_CELL == 64) + +#define UMOD_SHIFT 32 +#define UMOD_MASK 0x00000000ffffffff + +#endif + +UNS16 m64UMod(DPUNS *pUD, UNS16 base) { - UNS64 ud; + DPUNS ud; UNSQR qr; - UNS64 result; + DPUNS result; result.hi = result.lo = 0; ud.hi = 0; - ud.lo = pUD->hi >> 16; - qr = ficlLongDiv(ud, (UNS32)base); - result.hi = qr.quot << 16; + ud.lo = pUD->hi >> UMOD_SHIFT; + qr = ficlLongDiv(ud, (FICL_UNS)base); + result.hi = qr.quot << UMOD_SHIFT; - ud.lo = (qr.rem << 16) | (pUD->hi & 0x0000ffff); - qr = ficlLongDiv(ud, (UNS32)base); - result.hi |= qr.quot & 0x0000ffff; + ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->hi & UMOD_MASK); + qr = ficlLongDiv(ud, (FICL_UNS)base); + result.hi |= qr.quot & UMOD_MASK; - ud.lo = (qr.rem << 16) | (pUD->lo >> 16); - qr = ficlLongDiv(ud, (UNS32)base); - result.lo = qr.quot << 16; + ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo >> UMOD_SHIFT); + qr = ficlLongDiv(ud, (FICL_UNS)base); + result.lo = qr.quot << UMOD_SHIFT; - ud.lo = (qr.rem << 16) | (pUD->lo & 0x0000ffff); - qr = ficlLongDiv(ud, (UNS32)base); - result.lo |= qr.quot & 0x0000ffff; + ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo & UMOD_MASK); + qr = ficlLongDiv(ud, (FICL_UNS)base); + result.lo |= qr.quot & UMOD_MASK; *pUD = result; @@ -294,3 +309,218 @@ UNS16 m64UMod(UNS64 *pUD, UNS16 base) } +/************************************************************************** +** Contributed by +** Michael A. Gauland gaulandm@mdhost.cse.tek.com +**************************************************************************/ +#if PORTABLE_LONGMULDIV != 0 +/************************************************************************** + m 6 4 A d d +** +**************************************************************************/ +DPUNS m64Add(DPUNS x, DPUNS y) +{ + DPUNS result; + int carry; + + result.hi = x.hi + y.hi; + result.lo = x.lo + y.lo; + + + carry = ((x.lo | y.lo) & CELL_HI_BIT) && !(result.lo & CELL_HI_BIT); + carry |= ((x.lo & y.lo) & CELL_HI_BIT); + + if (carry) + { + result.hi++; + } + + return result; +} + + +/************************************************************************** + m 6 4 S u b +** +**************************************************************************/ +DPUNS m64Sub(DPUNS x, DPUNS y) +{ + DPUNS result; + + result.hi = x.hi - y.hi; + result.lo = x.lo - y.lo; + + if (x.lo < y.lo) + { + result.hi--; + } + + return result; +} + + +/************************************************************************** + m 6 4 A S L +** 64 bit left shift +**************************************************************************/ +DPUNS m64ASL( DPUNS x ) +{ + DPUNS result; + + result.hi = x.hi << 1; + if (x.lo & CELL_HI_BIT) + { + result.hi++; + } + + result.lo = x.lo << 1; + + return result; +} + + +/************************************************************************** + m 6 4 A S R +** 64 bit right shift (unsigned - no sign extend) +**************************************************************************/ +DPUNS m64ASR( DPUNS x ) +{ + DPUNS result; + + result.lo = x.lo >> 1; + if (x.hi & 1) + { + result.lo |= CELL_HI_BIT; + } + + result.hi = x.hi >> 1; + return result; +} + + +/************************************************************************** + m 6 4 O r +** 64 bit bitwise OR +**************************************************************************/ +DPUNS m64Or( DPUNS x, DPUNS y ) +{ + DPUNS result; + + result.hi = x.hi | y.hi; + result.lo = x.lo | y.lo; + + return result; +} + + +/************************************************************************** + m 6 4 C o m p a r e +** Return -1 if x < y; 0 if x==y, and 1 if x > y. +**************************************************************************/ +int m64Compare(DPUNS x, DPUNS y) +{ + int result; + + if (x.hi > y.hi) + { + result = +1; + } + else if (x.hi < y.hi) + { + result = -1; + } + else + { + /* High parts are equal */ + if (x.lo > y.lo) + { + result = +1; + } + else if (x.lo < y.lo) + { + result = -1; + } + else + { + result = 0; + } + } + + return result; +} + + +/************************************************************************** + 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 +**************************************************************************/ +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) +{ + DPUNS result = { 0, 0 }; + DPUNS addend; + + addend.lo = y; + addend.hi = 0; /* No sign extension--arguments are unsigned */ + + while (x != 0) + { + if ( x & 1) + { + result = m64Add(result, addend); + } + x >>= 1; + addend = m64ASL(addend); + } + return result; +} + + +/************************************************************************** + 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 +**************************************************************************/ +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y) +{ + UNSQR result; + DPUNS quotient; + DPUNS subtrahend; + DPUNS mask; + + quotient.lo = 0; + quotient.hi = 0; + + subtrahend.lo = y; + subtrahend.hi = 0; + + mask.lo = 1; + mask.hi = 0; + + while ((m64Compare(subtrahend, q) < 0) && + (subtrahend.hi & CELL_HI_BIT) == 0) + { + mask = m64ASL(mask); + subtrahend = m64ASL(subtrahend); + } + + while (mask.lo != 0 || mask.hi != 0) + { + if (m64Compare(subtrahend, q) <= 0) + { + q = m64Sub( q, subtrahend); + quotient = m64Or(quotient, mask); + } + mask = m64ASR(mask); + subtrahend = m64ASR(subtrahend); + } + + result.quot = quotient.lo; + result.rem = q.lo; + return result; +} + +#endif + diff --git a/sys/boot/ficl/math64.h b/sys/boot/ficl/math64.h index 2b7df37..a98af9ab 100644 --- a/sys/boot/ficl/math64.h +++ b/sys/boot/ficl/math64.h @@ -24,8 +24,14 @@ ** 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. +** */ +/* $FreeBSD$ */ + #if !defined (__MATH64_H__) #define __MATH64_H__ @@ -33,25 +39,37 @@ extern "C" { #endif -INT64 m64Abs(INT64 x); -int m64IsNegative(INT64 x); -UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add); -INT64 m64MulI(INT32 x, INT32 y); -INT64 m64Negate(INT64 x); -INTQR m64FlooredDivI(INT64 num, INT32 den); -void i64Push(FICL_STACK *pStack, INT64 i64); -INT64 i64Pop(FICL_STACK *pStack); -void u64Push(FICL_STACK *pStack, UNS64 u64); -UNS64 u64Pop(FICL_STACK *pStack); -INTQR m64SymmetricDivI(INT64 num, INT32 den); -UNS16 m64UMod(UNS64 *pUD, UNS16 base); +DPINT m64Abs(DPINT x); +int m64IsNegative(DPINT x); +DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add); +DPINT m64MulI(FICL_INT x, FICL_INT y); +DPINT m64Negate(DPINT x); +INTQR m64FlooredDivI(DPINT num, FICL_INT den); +void i64Push(FICL_STACK *pStack, DPINT i64); +DPINT i64Pop(FICL_STACK *pStack); +void u64Push(FICL_STACK *pStack, DPUNS u64); +DPUNS u64Pop(FICL_STACK *pStack); +INTQR m64SymmetricDivI(DPINT num, FICL_INT den); +UNS16 m64UMod(DPUNS *pUD, UNS16 base); + + +#if PORTABLE_LONGMULDIV != 0 /* see sysdep.h */ +DPUNS m64Add(DPUNS x, DPUNS y); +DPUNS m64ASL( DPUNS x ); +DPUNS m64ASR( DPUNS x ); +int m64Compare(DPUNS x, DPUNS y); +DPUNS m64Or( DPUNS x, DPUNS y ); +DPUNS m64Sub(DPUNS x, DPUNS y); +#endif #define i64Extend(i64) (i64).hi = ((i64).lo < 0) ? -1L : 0 -#define m64CastIU(i64) (*(UNS64 *)(&(i64))) -#define m64CastUI(u64) (*(INT64 *)(&(u64))) +#define m64CastIU(i64) (*(DPUNS *)(&(i64))) +#define m64CastUI(u64) (*(DPINT *)(&(u64))) #define m64CastQRIU(iqr) (*(UNSQR *)(&(iqr))) #define m64CastQRUI(uqr) (*(INTQR *)(&(uqr))) +#define CELL_HI_BIT (1L << (BITS_PER_CELL-1)) + #ifdef __cplusplus } #endif diff --git a/sys/boot/ficl/softwords/ficllocal.fr b/sys/boot/ficl/softwords/ficllocal.fr new file mode 100644 index 0000000..c916089 --- /dev/null +++ b/sys/boot/ficl/softwords/ficllocal.fr @@ -0,0 +1,49 @@ +\ ** ficl/softwords/ficllocal.fr +\ ** stack comment style local syntax... +\ {{ a b c -- d e }} +\ variables before the "--" are initialized in reverse order +\ from the stack. Those after the "--" are zero initialized +\ Uses locals... +\ locstate: 0 = looking for -- or }} +\ 1 = found -- +\ +\ $FreeBSD$ + +hide +0 constant zero + +: ?-- s" --" compare 0= ; +: ?}} s" }}" compare 0= ; + +set-current + +: {{ + 0 dup locals| nLocs locstate | + begin + parse-word + ?dup 0= abort" Error: out of text without seeing }}" + 2dup 2dup ?-- -rot ?}} or 0= + while + nLocs 1+ to nLocs + repeat + + ?-- if 1 to locstate endif + + nLocs 0 do + (local) + loop + + locstate 1 = if + begin + parse-word + 2dup ?}} 0= + while + postpone zero (local) + repeat + 2drop + endif + + 0 0 (local) +; immediate compile-only + +previous diff --git a/sys/boot/ficl/softwords/ifbrack.fr b/sys/boot/ficl/softwords/ifbrack.fr new file mode 100644 index 0000000..6716e93 --- /dev/null +++ b/sys/boot/ficl/softwords/ifbrack.fr @@ -0,0 +1,56 @@ +\ ** ficl/softwords/ifbrack.fr +\ ** ANS conditional compile directives [if] [else] [then] +\ ** Requires ficl 2.0 or greater... + +\ $FreeBSD$ + +hidden dup >search ficl-set-current + +: ?[if] ( c-addr u -- c-addr u flag ) + 2dup 2dup + s" [if]" compare 0= >r + s" [IF]" compare 0= r> + or +; + +: ?[else] ( c-addr u -- c-addr u flag ) + 2dup 2dup + s" [else]" compare 0= >r + s" [ELSE]" compare 0= r> + or +; + +: ?[then] ( c-addr u -- c-addr u flag ) + 2dup 2dup + s" [then]" compare 0= >r + s" [THEN]" compare 0= r> + or +; + +set-current + +: [else] ( -- ) + 1 \ ( level ) + begin + begin + parse-word dup while \ ( level addr len ) + ?[if] if \ ( level addr len ) + 2drop 1+ \ ( level ) + else \ ( level addr len ) + ?[else] if \ ( level addr len ) + 2drop 1- dup if 1+ endif + else + ?[then] if 2drop 1- else 2drop endif + endif + endif ?dup 0= if exit endif \ level + repeat 2drop \ level + refill 0= until \ level + drop +; immediate + +: [if] ( flag -- ) +0= if postpone [else] then ; immediate + +: [then] ( -- ) ; immediate + +previous diff --git a/sys/boot/ficl/softwords/softcore.fr b/sys/boot/ficl/softwords/softcore.fr index b57416b..a292dbe 100644 --- a/sys/boot/ficl/softwords/softcore.fr +++ b/sys/boot/ficl/softwords/softcore.fr @@ -3,6 +3,8 @@ \ ** John Sadler (john_sadler@alum.mit.edu) \ ** September, 1998 +\ $FreeBSD$ + \ ** Ficl USER variables \ ** See words.c for primitive def'n of USER \ #if FICL_WANT_USER @@ -49,6 +51,8 @@ decimal 32 constant bl : erase ( addr u -- ) 0 fill ; : nip ( y x -- x ) swap drop ; : tuck ( y x -- x y x) swap over ; +: within ( test low high -- flag ) over - >r - r> u< ; + \ ** LOCAL EXT word set \ #if FICL_WANT_LOCALS @@ -78,38 +82,6 @@ decimal 32 constant bl loop drop ; -\ ** Some TOOLS EXT words, straight from the standard -: [else] ( -- ) - 1 begin \ level - begin - bl word count dup while \ level adr len - 2dup s" [IF]" compare 0= >r - 2dup s" [if]" compare 0= r> or - if \ level adr len - 2drop 1+ \ level' - else \ level adr len - 2dup s" [ELSE]" compare 0= >r - 2dup s" [else]" compare 0= r> or - if \ level adr len - 2drop 1- dup if 1+ then \ level' - else \ level adr len - 2dup - s" [THEN]" compare 0= >r \ level adr len - s" [then]" compare 0= r> or - if \ level - 1- \ level' - then - then - then ?dup 0= if exit then \ level' - repeat 2drop \ level - refill 0= until \ level - drop -; immediate - -: [if] ( flag -- ) -0= if postpone [else] then ; immediate - -: [then] ( -- ) ; immediate \ ** SEARCH+EXT words and ficl helpers \ : wordlist ( -- ) diff --git a/sys/boot/ficl/stack.c b/sys/boot/ficl/stack.c index aee9f8f..059137c 100644 --- a/sys/boot/ficl/stack.c +++ b/sys/boot/ficl/stack.c @@ -6,6 +6,8 @@ ** *******************************************************************/ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdlib.h> #else @@ -200,12 +202,12 @@ void *stackPopPtr(FICL_STACK *pStack) return (*--pStack->sp).p; } -UNS32 stackPopUNS32(FICL_STACK *pStack) +FICL_UNS stackPopUNS(FICL_STACK *pStack) { return (*--pStack->sp).u; } -INT32 stackPopINT32(FICL_STACK *pStack) +FICL_INT stackPopINT(FICL_STACK *pStack) { return (*--pStack->sp).i; } @@ -226,12 +228,12 @@ void stackPushPtr(FICL_STACK *pStack, void *ptr) *pStack->sp++ = LVALUEtoCELL(ptr); } -void stackPushUNS32(FICL_STACK *pStack, UNS32 u) +void stackPushUNS(FICL_STACK *pStack, FICL_UNS u) { *pStack->sp++ = LVALUEtoCELL(u); } -void stackPushINT32(FICL_STACK *pStack, INT32 i) +void stackPushINT(FICL_STACK *pStack, FICL_INT i) { *pStack->sp++ = LVALUEtoCELL(i); } diff --git a/sys/boot/ficl/sysdep.c b/sys/boot/ficl/sysdep.c index 8d4ed74..2a5346a 100644 --- a/sys/boot/ficl/sysdep.c +++ b/sys/boot/ficl/sysdep.c @@ -7,6 +7,8 @@ ** *******************************************************************/ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdio.h> #include <stdlib.h> @@ -22,9 +24,10 @@ ******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith */ -UNS64 ficlLongMul(UNS32 x, UNS32 y) +#if PORTABLE_LONGMULDIV == 0 +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y) { - UNS64 q; + DPUNS q; u_int64_t qx; qx = (u_int64_t)x * (u_int64_t) y; @@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y) return q; } -UNSQR ficlLongDiv(UNS64 q, UNS32 y) +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y) { UNSQR result; u_int64_t qx, qh; @@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y) return result; } +#endif void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline) { @@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); - c=(u_char)stackPopINT32(pVM->pStack); + port=stackPopUNS(pVM->pStack); + c=(u_char)stackPopINT(pVM->pStack); outb(port,c); } @@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM) u_char c; u_int32_t port; - port=stackPopUNS32(pVM->pStack); + port=stackPopUNS(pVM->pStack); c=inb(port); - stackPushINT32(pVM->pStack,c); + stackPushINT(pVM->pStack,c); } #endif #endif diff --git a/sys/boot/ficl/sysdep.h b/sys/boot/ficl/sysdep.h index 170a690..99ccd58 100644 --- a/sys/boot/ficl/sysdep.h +++ b/sys/boot/ficl/sysdep.h @@ -32,6 +32,8 @@ ** send me email at the address above. */ +/* $FreeBSD$ */ + #if !defined (__SYSDEP_H__) #define __SYSDEP_H__ @@ -60,48 +62,75 @@ #endif +/* +** System dependent data type declarations... +*/ #if !defined INT32 -#define INT32 int32_t +#define INT32 long #endif #if !defined UNS32 -#define UNS32 u_int32_t +#define UNS32 unsigned long #endif #if !defined UNS16 -#define UNS16 u_int16_t +#define UNS16 unsigned short #endif #if !defined UNS8 -#define UNS8 u_int8_t +#define UNS8 unsigned char #endif #if !defined NULL #define NULL ((void *)0) #endif +/* +** 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. +*/ +#if !defined FICL_INT +#define FICL_INT INT32 +#endif + +#if !defined FICL_UNS +#define FICL_UNS UNS32 +#endif + +/* +** Ficl presently supports values of 32 and 64 for BITS_PER_CELL +*/ +#if !defined BITS_PER_CELL +#define BITS_PER_CELL 32 +#endif + +#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64)) + Error! +#endif + typedef struct { - UNS32 hi; - UNS32 lo; -} UNS64; + FICL_UNS hi; + FICL_UNS lo; +} DPUNS; typedef struct { - UNS32 quot; - UNS32 rem; + FICL_UNS quot; + FICL_UNS rem; } UNSQR; typedef struct { - INT32 hi; - INT32 lo; -} INT64; + FICL_INT hi; + FICL_INT lo; +} DPINT; typedef struct { - INT32 quot; - INT32 rem; + FICL_INT quot; + FICL_INT rem; } INTQR; @@ -115,6 +144,30 @@ typedef struct #endif /* +** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be +** defined in C in sysdep.c. Use this if you cannot easily +** generate an inline asm definition +*/ +#if !defined (PORTABLE_LONGMULDIV) +#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 +** chokes with an internal compiler error on the function version. +** in release mode. Sheesh. +*/ +#if !defined INLINE_INNER_LOOP +#if defined _DEBUG +#define INLINE_INNER_LOOP 0 +#else +#define INLINE_INNER_LOOP 1 +#endif +#endif + +/* ** FICL_ROBUST enables bounds checking of stacks and the dictionary. ** This will detect stack over and underflows and dictionary overflows. ** Any exceptional condition will result in an assertion failure. @@ -192,7 +245,7 @@ typedef struct ** pointer address must be aligned. This value is usually ** either 1 or 2, depending on the memory architecture ** of the target system; 2 is safe on any 16 or 32 bit -** machine. +** machine. 3 would be appropriate for a 64 bit machine. */ #if !defined FICL_ALIGN #define FICL_ALIGN 2 @@ -215,9 +268,8 @@ 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); - +void *ficlRealloc(void *p, size_t size); /* ** Stub function for dictionary access control - does nothing ** by default, user can redefine to guarantee exclusive dict @@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock); /* ** 64 bit integer math support routines: multiply two UNS32s -** to get a 64 bit prodict, & divide the product by an UNS32 +** to get a 64 bit product, & divide the product by an UNS32 ** to get an UNS32 quotient and remainder. Much easier in asm ** on a 32 bit CPU than in C, which usually doesn't support ** the double length result (but it should). */ -UNS64 ficlLongMul(UNS32 x, UNS32 y); -UNSQR ficlLongDiv(UNS64 q, UNS32 y); +DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y); +UNSQR ficlLongDiv(DPUNS q, FICL_UNS y); #endif /*__SYSDEP_H__*/ diff --git a/sys/boot/ficl/testmain.c b/sys/boot/ficl/testmain.c index bfb7364..657d609 100644 --- a/sys/boot/ficl/testmain.c +++ b/sys/boot/ficl/testmain.c @@ -3,9 +3,12 @@ ** */ +/* $FreeBSD$ */ + #include <stdlib.h> #include <stdio.h> #include <string.h> +#include <time.h> #include <sys/types.h> #include <sys/stat.h> #include <unistd.h> @@ -144,7 +147,7 @@ static void ficlLoad(FICL_VM *pVM) if (len <= 0) continue; - result = ficlExec(pVM, cp, len); + result = ficlExecC(pVM, cp, len); if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT ) { pVM->sourceID = id; @@ -154,7 +157,7 @@ static void ficlLoad(FICL_VM *pVM) } } /* - ** Pass an empty line with SOURCE-ID == 0 to flush + ** Pass an empty line with SOURCE-ID == -1 to flush ** any pending REFILLs (as required by FILE wordset) */ pVM->sourceID.i = -1; @@ -221,14 +224,46 @@ static void ficlBreak(FICL_VM *pVM) return; } +static void ficlClock(FICL_VM *pVM) +{ + clock_t now = clock(); + stackPushUNS(pVM->pStack, (UNS32)now); + return; +} + +static void clocksPerSec(FICL_VM *pVM) +{ + stackPushUNS(pVM->pStack, CLOCKS_PER_SEC); + return; +} + + +static void execxt(FICL_VM *pVM) +{ + FICL_WORD *pFW; +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + + pFW = stackPopPtr(pVM->pStack); + ficlExecXT(pVM, pFW); + + return; +} + + void buildTestInterface(void) { ficlBuild("break", ficlBreak, FW_DEFAULT); + ficlBuild("clock", ficlClock, FW_DEFAULT); ficlBuild("cd", ficlChDir, FW_DEFAULT); + ficlBuild("execxt", execxt, FW_DEFAULT); ficlBuild("load", ficlLoad, FW_DEFAULT); ficlBuild("pwd", ficlGetCWD, FW_DEFAULT); ficlBuild("system", ficlSystem, FW_DEFAULT); ficlBuild("spewhash", spewHash, FW_DEFAULT); + ficlBuild("clocks/sec", + clocksPerSec, FW_DEFAULT); return; } @@ -236,7 +271,7 @@ void buildTestInterface(void) int main(int argc, char **argv) { - char in[256]; + char in[nINBUF]; FICL_VM *pVM; ficlInitSystem(10000); diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c index ebdf944..bb6b1f8 100644 --- a/sys/boot/ficl/vm.c +++ b/sys/boot/ficl/vm.c @@ -1,4 +1,4 @@ -/*******************************************************************
+/******************************************************************* ** v m . c ** Forth Inspired Command Language - virtual machine methods ** Author: John Sadler (john_sadler@alum.mit.edu) @@ -13,6 +13,8 @@ ** of the interp. */ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdlib.h> #include <stdio.h> @@ -47,11 +49,9 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack) if (pVM == NULL) { pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM)); - pVM->pStack = NULL; - pVM->rStack = NULL; - pVM->link = NULL; + assert (pVM); + memset(pVM, 0, sizeof (FICL_VM)); } - assert (pVM); if (pVM->pStack) stackDelete(pVM->pStack); @@ -87,7 +87,10 @@ void vmDelete (FICL_VM *pVM) /************************************************************************** v m E x e c u t e -** +** Sets up the specified word to be run by the inner interpreter. +** Executes the word's code part immediately, but in the case of +** colon definition, the definition itself needs the inner interp +** to complete. This does not happen until control reaches ficlExec **************************************************************************/ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) { @@ -98,6 +101,24 @@ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord) /************************************************************************** + v m I n n e r L o o p +** the mysterious inner interpreter... +** This loop is the address interpreter that makes colon definitions +** work. Upon entry, it assumes that the IP points to an entry in +** a definition (the body of a colon word). It runs one word at a time +** until something does vmThrow. The catcher for this is expected to exist +** in the calling code. +** vmThrow gets you out of this loop with a longjmp() +** Visual C++ 5 chokes on this loop in Release mode. Aargh. +**************************************************************************/ +#if INLINE_INNER_LOOP == 0 +void vmInnerLoop(FICL_VM *pVM) +{ + M_INNER_LOOP(pVM); +} +#endif + +/************************************************************************** v m G e t S t r i n g ** Parses a string out of the VM input buffer and copies up to the first ** FICL_STRING_MAX characters to the supplied destination buffer, a @@ -151,22 +172,23 @@ STRINGINFO vmGetWord(FICL_VM *pVM) **************************************************************************/ STRINGINFO vmGetWord0(FICL_VM *pVM) { - char *pSrc = vmGetInBuf(pVM); + char *pSrc = vmGetInBuf(pVM); + char *pEnd = vmGetInBufEnd(pVM); STRINGINFO si; UNS32 count = 0; char ch; - pSrc = skipSpace(pSrc,pVM->tib.end); + pSrc = skipSpace(pSrc, pEnd); SI_SETPTR(si, pSrc); - for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc) + for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc) { count++; } SI_SETLEN(si, count); - if ((pVM->tib.end != pSrc) && isspace(ch)) /* skip one trailing delimiter */ + if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); @@ -210,16 +232,16 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim) { STRINGINFO si; char *pSrc = vmGetInBuf(pVM); - char ch; + char *pEnd = vmGetInBufEnd(pVM); + char ch; - while ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* skip lead delimiters */ + while ((pSrc != pEnd) && (*pSrc == delim)) /* skip lead delimiters */ pSrc++; SI_SETPTR(si, pSrc); /* mark start of text */ - for (ch = *pSrc; (pVM->tib.end != pSrc) - && (ch != delim) - && (ch != '\0') + for (ch = *pSrc; (pSrc != pEnd) + && (ch != delim) && (ch != '\r') && (ch != '\n'); ch = *++pSrc) { @@ -229,7 +251,7 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim) /* set length of result */ SI_SETLEN(si, pSrc - SI_PTR(si)); - if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */ + if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); @@ -264,7 +286,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, INT32 size, TIB *pSaveTib) +void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib) { if (pSaveTib) { @@ -272,7 +294,7 @@ void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib) } pVM->tib.cp = text; - pVM->tib.end = text + size; + pVM->tib.end = text + nChars; pVM->tib.index = 0; } @@ -361,7 +383,8 @@ void vmTextOut(FICL_VM *pVM, char *text, int fNewline) **************************************************************************/ void vmThrow(FICL_VM *pVM, int except) { - longjmp(*(pVM->pState), except); + if (pVM->pState) + longjmp(*(pVM->pState), except); } @@ -433,32 +456,65 @@ char digit_to_char(int value) /************************************************************************** + i s P o w e r O f T w o +** Tests whether supplied argument is an integer power of 2 (2**n) +** where 32 > n > 1, and returns n if so. Otherwise returns zero. +**************************************************************************/ +int isPowerOfTwo(FICL_UNS u) +{ + int i = 1; + FICL_UNS t = 2; + + for (; ((t <= u) && (t != 0)); i++, t <<= 1) + { + if (u == t) + return i; + } + + return 0; +} + + +/************************************************************************** l t o a ** **************************************************************************/ -char *ltoa( INT32 value, char *string, int radix ) +char *ltoa( FICL_INT value, char *string, int radix ) { /* convert long to string, any base */ char *cp = string; int sign = ((radix == 10) && (value < 0)); - UNSQR result; - UNS64 v; + int pwr; assert(radix > 1); assert(radix < 37); assert(string); + pwr = isPowerOfTwo((FICL_UNS)radix); + if (sign) value = -value; if (value == 0) *cp++ = '0'; + else if (pwr != 0) + { + FICL_UNS v = (FICL_UNS) value; + FICL_UNS mask = (FICL_UNS) ~(-1 << pwr); + while (v) + { + *cp++ = digits[v & mask]; + v >>= pwr; + } + } else { + UNSQR result; + DPUNS v; v.hi = 0; - v.lo = (UNS32)value; + v.lo = (FICL_UNS)value; while (v.lo) { - result = ficlLongDiv(v, (UNS32)radix); + result = ficlLongDiv(v, (FICL_UNS)radix); *cp++ = digits[result.rem]; v.lo = result.quot; } @@ -477,10 +533,10 @@ char *ltoa( INT32 value, char *string, int radix ) u l t o a ** **************************************************************************/ -char *ultoa(UNS32 value, char *string, int radix ) +char *ultoa(FICL_UNS value, char *string, int radix ) { /* convert long to string, any base */ char *cp = string; - UNS64 ud; + DPUNS ud; UNSQR result; assert(radix > 1); @@ -554,8 +610,8 @@ 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. +** If the pointer reaches "end" first, stop there. Pass NULL to +** suppress this behavior. **************************************************************************/ char *skipSpace(char *cp, char *end) { diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c index e86f25f..a24e9ed 100644 --- a/sys/boot/ficl/words.c +++ b/sys/boot/ficl/words.c @@ -7,6 +7,8 @@ ** *******************************************************************/ +/* $FreeBSD$ */ + #ifdef TESTMAIN #include <stdlib.h> #include <stdio.h> @@ -29,11 +31,11 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si); ** check for structure completion. */ static char doTag[] = "do"; -static char ifTag[] = "if"; static char colonTag[] = "colon"; static char leaveTag[] = "leave"; -static char beginTag[] = "begin"; -static char whileTag[] = "while"; + +static char destTag[] = "target"; +static char origTag[] = "origin"; /* ** Pointers to various words in the dictionary @@ -95,8 +97,7 @@ static void matchControlTag(FICL_VM *pVM, char *tag) char *cp = (char *)stackPopPtr(pVM->pStack); if ( strcmp(cp, tag) ) { - vmTextOut(pVM, "Warning -- unmatched control word: ", 0); - vmTextOut(pVM, tag, 1); + vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag); } return; @@ -174,7 +175,7 @@ static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) static int isNumber(FICL_VM *pVM, STRINGINFO si) { - INT32 accum = 0; + FICL_INT accum = 0; char isNeg = FALSE; unsigned base = pVM->base; char *cp = SI_PTR(si); @@ -200,17 +201,14 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si) while (count-- && ((ch = *cp++) != '\0')) { - if (ch < '0') + if (!(isdigit(ch)||isalpha(ch))) return FALSE; digit = ch - '0'; if (digit > 9) digit = tolower(ch) - 'a' + 10; - /* - ** Note: following test also catches chars between 9 and a - ** because 'digit' is unsigned! - */ + if (digit >= base) return FALSE; @@ -218,9 +216,9 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si) } if (isNeg) - accum = -accum; + accum = -accum; - stackPushINT32(pVM->pStack, accum); + stackPushINT(pVM->pStack, accum); return TRUE; } @@ -233,11 +231,11 @@ static int isNumber(FICL_VM *pVM, STRINGINFO si) static void add(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - i = stackPopINT32(pVM->pStack); + i = stackPopINT(pVM->pStack); i += stackGetTop(pVM->pStack).i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; @@ -245,11 +243,11 @@ static void add(FICL_VM *pVM) static void sub(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - i = stackPopINT32(pVM->pStack); + i = stackPopINT(pVM->pStack); i = stackGetTop(pVM->pStack).i - i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; @@ -257,11 +255,11 @@ static void sub(FICL_VM *pVM) static void mul(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - i = stackPopINT32(pVM->pStack); + i = stackPopINT(pVM->pStack); i *= stackGetTop(pVM->pStack).i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; @@ -269,22 +267,22 @@ static void mul(FICL_VM *pVM) static void negate(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - i = -stackPopINT32(pVM->pStack); - stackPushINT32(pVM->pStack, i); + i = -stackPopINT(pVM->pStack); + stackPushINT(pVM->pStack, i); return; } static void ficlDiv(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - i = stackPopINT32(pVM->pStack); + i = stackPopINT(pVM->pStack); i = stackGetTop(pVM->pStack).i / i; stackSetTop(pVM->pStack, LVALUEtoCELL(i)); return; @@ -301,26 +299,26 @@ static void ficlDiv(FICL_VM *pVM) */ static void slashMod(FICL_VM *pVM) { - INT64 n1; - INT32 n2; + DPINT n1; + FICL_INT n2; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 2); #endif - n2 = stackPopINT32(pVM->pStack); - n1.lo = stackPopINT32(pVM->pStack); + n2 = stackPopINT(pVM->pStack); + n1.lo = stackPopINT(pVM->pStack); i64Extend(n1); qr = m64SymmetricDivI(n1, n2); - stackPushINT32(pVM->pStack, qr.rem); - stackPushINT32(pVM->pStack, qr.quot); + stackPushINT(pVM->pStack, qr.rem); + stackPushINT(pVM->pStack, qr.quot); return; } static void onePlus(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif @@ -332,7 +330,7 @@ static void onePlus(FICL_VM *pVM) static void oneMinus(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif @@ -344,7 +342,7 @@ static void oneMinus(FICL_VM *pVM) static void twoMul(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif @@ -356,7 +354,7 @@ static void twoMul(FICL_VM *pVM) static void twoDiv(FICL_VM *pVM) { - INT32 i; + FICL_INT i; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif @@ -368,40 +366,40 @@ static void twoDiv(FICL_VM *pVM) static void mulDiv(FICL_VM *pVM) { - INT32 x, y, z; - INT64 prod; + FICL_INT x, y, z; + DPINT prod; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 1); #endif - z = stackPopINT32(pVM->pStack); - y = stackPopINT32(pVM->pStack); - x = stackPopINT32(pVM->pStack); + z = stackPopINT(pVM->pStack); + y = stackPopINT(pVM->pStack); + x = stackPopINT(pVM->pStack); prod = m64MulI(x,y); x = m64SymmetricDivI(prod, z).quot; - stackPushINT32(pVM->pStack, x); + stackPushINT(pVM->pStack, x); return; } static void mulDivRem(FICL_VM *pVM) { - INT32 x, y, z; - INT64 prod; + FICL_INT x, y, z; + DPINT prod; INTQR qr; #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 2); #endif - z = stackPopINT32(pVM->pStack); - y = stackPopINT32(pVM->pStack); - x = stackPopINT32(pVM->pStack); + z = stackPopINT(pVM->pStack); + y = stackPopINT(pVM->pStack); + x = stackPopINT(pVM->pStack); prod = m64MulI(x,y); qr = m64SymmetricDivI(prod, z); - stackPushINT32(pVM->pStack, qr.rem); - stackPushINT32(pVM->pStack, qr.quot); + stackPushINT(pVM->pStack, qr.rem); + stackPushINT(pVM->pStack, qr.quot); return; } @@ -636,11 +634,11 @@ static void displayCellNoPad(FICL_VM *pVM) static void uDot(FICL_VM *pVM) { - UNS32 u; + FICL_UNS u; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - u = stackPopUNS32(pVM->pStack); + u = stackPopUNS(pVM->pStack); ultoa(u, pVM->pad, pVM->base); strcat(pVM->pad, " "); vmTextOut(pVM, pVM->pad, 0); @@ -650,11 +648,11 @@ static void uDot(FICL_VM *pVM) static void hexDot(FICL_VM *pVM) { - UNS32 u; + FICL_UNS u; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - u = stackPopUNS32(pVM->pStack); + u = stackPopUNS(pVM->pStack); ultoa(u, pVM->pad, 16); strcat(pVM->pad, " "); vmTextOut(pVM, pVM->pad, 0); @@ -700,7 +698,7 @@ static void depth(FICL_VM *pVM) vmCheckStack(pVM, 0, 1); #endif i = stackDepth(pVM->pStack); - stackPushINT32(pVM->pStack, i); + stackPushINT(pVM->pStack, i); return; } @@ -860,7 +858,7 @@ static void emit(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - i = stackPopINT32(pVM->pStack); + i = stackPopINT(pVM->pStack); cp[0] = (char)i; cp[1] = '\0'; vmTextOut(pVM, cp, 0); @@ -877,10 +875,11 @@ static void cr(FICL_VM *pVM) static void commentLine(FICL_VM *pVM) { - char *cp = vmGetInBuf(pVM); + char *cp = vmGetInBuf(pVM); + char *pEnd = vmGetInBufEnd(pVM); char ch = *cp; - while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n')) + while ((cp != pEnd) && (ch != '\r') && (ch != '\n')) { ch = *++cp; } @@ -890,11 +889,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 ((pVM->tib.end != cp) && (ch != '\0')) + if (cp != pEnd) { cp++; - if ( (pVM->tib.end != cp) && (ch != *cp) + if ( (cp != pEnd) && (ch != *cp) && ((*cp == '\r') || (*cp == '\n')) ) cp++; } @@ -1004,7 +1003,7 @@ static void wFetch(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif pw = (UNS16 *)stackPopPtr(pVM->pStack); - stackPushUNS32(pVM->pStack, (UNS32)*pw); + stackPushUNS(pVM->pStack, (FICL_UNS)*pw); return; } @@ -1025,7 +1024,7 @@ static void cFetch(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif pc = (UNS8 *)stackPopPtr(pVM->pStack); - stackPushUNS32(pVM->pStack, (UNS32)*pc); + stackPushUNS(pVM->pStack, (FICL_UNS)*pc); return; } @@ -1055,8 +1054,8 @@ static void ifCoIm(FICL_VM *pVM) assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); - markBranch(dp, pVM, ifTag); - dictAppendUNS32(dp, 1); + markBranch(dp, pVM, origTag); + dictAppendUNS(dp, 1); return; } @@ -1074,12 +1073,12 @@ void ifParen(FICL_VM *pVM) static void ifParen(FICL_VM *pVM) #endif { - UNS32 flag; + FICL_UNS flag; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - flag = stackPopUNS32(pVM->pStack); + flag = stackPopUNS(pVM->pStack); if (flag) { /* fall through */ @@ -1115,11 +1114,11 @@ static void elseCoIm(FICL_VM *pVM) assert(pBranchParen); /* (1) compile branch runtime */ dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); - matchControlTag(pVM, ifTag); + matchControlTag(pVM, origTag); patchAddr = (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ - markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */ - dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */ + markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */ + dictAppendUNS(dp, 1); /* (1) compile patch placeholder */ offset = dp->here - patchAddr; *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ @@ -1153,7 +1152,7 @@ static void branchParen(FICL_VM *pVM) static void endifCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); - resolveForwardBranch(dp, pVM, ifTag); + resolveForwardBranch(dp, pVM, origTag); return; } @@ -1185,7 +1184,7 @@ static void interpret(FICL_VM *pVM) vmBranchRelative(pVM, -1); /* - // Get next word...if out of text, we're done. + ** Get next word...if out of text, we're done. */ if (si.count == 0) vmThrow(pVM, VM_OUTOFTEXT); @@ -1294,7 +1293,7 @@ static void literalParen(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif - stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip)); + stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip)); vmBranchRelative(pVM, 1); return; } @@ -1432,7 +1431,7 @@ static void zeroEquals(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0); + c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0); stackPush(pVM->pStack, c); return; } @@ -1443,7 +1442,7 @@ static void zeroLess(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0); + c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0); stackPush(pVM->pStack, c); return; } @@ -1454,7 +1453,7 @@ static void zeroGreater(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0); + c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0); stackPush(pVM->pStack, c); return; } @@ -1468,7 +1467,7 @@ static void isEqual(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i)); + stackPushINT(pVM->pStack, FICL_BOOL(x.i == y.i)); return; } @@ -1480,19 +1479,19 @@ static void isLess(FICL_VM *pVM) #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i)); + stackPushINT(pVM->pStack, FICL_BOOL(x.i < y.i)); return; } static void uIsLess(FICL_VM *pVM) { - UNS32 u1, u2; + FICL_UNS u1, u2; #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - u2 = stackPopUNS32(pVM->pStack); - u1 = stackPopUNS32(pVM->pStack); - stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2)); + u2 = stackPopUNS(pVM->pStack); + u1 = stackPopUNS(pVM->pStack); + stackPushINT(pVM->pStack, FICL_BOOL(u1 < u2)); return; } @@ -1504,7 +1503,7 @@ static void isGreater(FICL_VM *pVM) #endif y = stackPop(pVM->pStack); x = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i)); + stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i)); return; } @@ -1516,7 +1515,7 @@ static void bitwiseAnd(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, x.i & y.i); + stackPushINT(pVM->pStack, x.i & y.i); return; } @@ -1528,7 +1527,7 @@ static void bitwiseOr(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, x.i | y.i); + stackPushINT(pVM->pStack, x.i | y.i); return; } @@ -1540,7 +1539,7 @@ static void bitwiseXor(FICL_VM *pVM) #endif x = stackPop(pVM->pStack); y = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, x.i ^ y.i); + stackPushINT(pVM->pStack, x.i ^ y.i); return; } @@ -1551,7 +1550,7 @@ static void bitwiseNot(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif x = stackPop(pVM->pStack); - stackPushINT32(pVM->pStack, ~x.i); + stackPushINT(pVM->pStack, ~x.i); return; } @@ -1593,7 +1592,7 @@ static void doCoIm(FICL_VM *pVM) ** of the loop - "leave" uses this... */ markBranch(dp, pVM, leaveTag); - dictAppendUNS32(dp, 0); + dictAppendUNS(dp, 0); /* ** Mark location of head of loop... */ @@ -1636,7 +1635,7 @@ static void qDoCoIm(FICL_VM *pVM) ** of the loop - "leave" uses this... */ markBranch(dp, pVM, leaveTag); - dictAppendUNS32(dp, 0); + dictAppendUNS(dp, 0); /* ** Mark location of head of loop... */ @@ -1728,8 +1727,8 @@ void loopParen(FICL_VM *pVM) static void loopParen(FICL_VM *pVM) #endif { - INT32 index = stackGetTop(pVM->rStack).i; - INT32 limit = stackFetch(pVM->rStack, 1).i; + FICL_INT index = stackGetTop(pVM->rStack).i; + FICL_INT limit = stackFetch(pVM->rStack, 1).i; index++; @@ -1753,9 +1752,9 @@ void plusLoopParen(FICL_VM *pVM) static void plusLoopParen(FICL_VM *pVM) #endif { - INT32 index = stackGetTop(pVM->rStack).i; - INT32 limit = stackFetch(pVM->rStack, 1).i; - INT32 increment = stackPop(pVM->pStack).i; + FICL_INT index = stackGetTop(pVM->rStack).i; + FICL_INT limit = stackFetch(pVM->rStack, 1).i; + FICL_INT increment = stackPop(pVM->pStack).i; int flag; index += increment; @@ -1891,7 +1890,7 @@ static void hex(FICL_VM *pVM) static void allot(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); - INT32 i = stackPopINT32(pVM->pStack); + FICL_INT i = stackPopINT(pVM->pStack); #if FICL_ROBUST dictCheck(dp, pVM, i); #endif @@ -1920,7 +1919,7 @@ static void comma(FICL_VM *pVM) static void cComma(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); - char c = (char)stackPopINT32(pVM->pStack); + char c = (char)stackPopINT(pVM->pStack); dictAppendChar(dp, c); return; } @@ -1928,8 +1927,8 @@ static void cComma(FICL_VM *pVM) static void cells(FICL_VM *pVM) { - INT32 i = stackPopINT32(pVM->pStack); - stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL)); + FICL_INT i = stackPopINT(pVM->pStack); + stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL)); return; } @@ -2067,7 +2066,7 @@ static void stringLit(FICL_VM *pVM) FICL_COUNT count = sp->count; char *cp = sp->text; stackPushPtr(pVM->pStack, cp); - stackPushUNS32(pVM->pStack, count); + stackPushUNS(pVM->pStack, count); cp += count + 1; cp = alignPtr(cp); pVM->ip = (IPTYPE)(void *)cp; @@ -2087,17 +2086,18 @@ static void dotQuoteCoIm(FICL_VM *pVM) static void dotParen(FICL_VM *pVM) { - char *pSrc = vmGetInBuf(pVM); - char *pDest = pVM->pad; + char *pSrc = vmGetInBuf(pVM); + char *pEnd = vmGetInBufEnd(pVM); + char *pDest = pVM->pad; char ch; - pSrc = skipSpace(pSrc,pVM->tib.end); + pSrc = skipSpace(pSrc, pEnd); - for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc) + for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) *pDest++ = ch; *pDest = '\0'; - if ((pVM->tib.end != pSrc) && (ch == ')')) + if ((pEnd != pSrc) && (ch == ')')) pSrc++; vmTextOut(pVM, pVM->pad, 0); @@ -2122,8 +2122,8 @@ static void sLiteralCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); char *cp, *cpDest; - UNS32 u; - u = stackPopUNS32(pVM->pStack); + FICL_UNS u; + u = stackPopUNS(pVM->pStack); cp = stackPopPtr(pVM->pStack); dictAppendCell(dp, LVALUEtoCELL(pStringLit)); @@ -2255,7 +2255,7 @@ static void toName(FICL_VM *pVM) { FICL_WORD *pFW = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, pFW->name); - stackPushUNS32(pVM->pStack, pFW->nName); + stackPushUNS(pVM->pStack, pFW->nName); return; } @@ -2304,7 +2304,7 @@ static void lessNumberSign(FICL_VM *pVM) static void numberSign(FICL_VM *pVM) { FICL_STRING *sp = PTRtoSTRING pVM->pad; - UNS64 u; + DPUNS u; UNS16 rem; u = u64Pop(pVM->pStack); @@ -2327,7 +2327,7 @@ static void numberSignGreater(FICL_VM *pVM) strrev(sp->text); stackDrop(pVM->pStack, 2); stackPushPtr(pVM->pStack, sp->text); - stackPushUNS32(pVM->pStack, sp->count); + stackPushUNS(pVM->pStack, sp->count); return; } @@ -2341,7 +2341,7 @@ static void numberSignGreater(FICL_VM *pVM) static void numberSignS(FICL_VM *pVM) { FICL_STRING *sp = PTRtoSTRING pVM->pad; - UNS64 u; + DPUNS u; UNS16 rem; u = u64Pop(pVM->pStack); @@ -2365,7 +2365,7 @@ static void numberSignS(FICL_VM *pVM) static void hold(FICL_VM *pVM) { FICL_STRING *sp = PTRtoSTRING pVM->pad; - int i = stackPopINT32(pVM->pStack); + int i = stackPopINT(pVM->pStack); sp->text[sp->count++] = (char) i; return; } @@ -2379,7 +2379,7 @@ static void hold(FICL_VM *pVM) static void sign(FICL_VM *pVM) { FICL_STRING *sp = PTRtoSTRING pVM->pad; - int i = stackPopINT32(pVM->pStack); + int i = stackPopINT(pVM->pStack); if (i < 0) sp->text[sp->count++] = '-'; return; @@ -2399,16 +2399,15 @@ static void sign(FICL_VM *pVM) ** was entirely converted. u2 is the number of unconverted characters in the ** string. An ambiguous condition exists if ud2 overflows during the ** conversion. -** TO DO: presently does not use ud1 hi cell - use it! **************************************************************************/ static void toNumber(FICL_VM *pVM) { - UNS32 count = stackPopUNS32(pVM->pStack); + FICL_UNS count = stackPopUNS(pVM->pStack); char *cp = (char *)stackPopPtr(pVM->pStack); - UNS64 accum; - UNS32 base = pVM->base; - UNS32 ch; - UNS32 digit; + DPUNS accum; + FICL_UNS base = pVM->base; + FICL_UNS ch; + FICL_UNS digit; accum = u64Pop(pVM->pStack); @@ -2433,7 +2432,7 @@ static void toNumber(FICL_VM *pVM) u64Push(pVM->pStack, accum); stackPushPtr (pVM->pStack, cp); - stackPushUNS32(pVM->pStack, count); + stackPushUNS(pVM->pStack, count); return; } @@ -2484,29 +2483,32 @@ 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) +** +** Note (sobral) this may not be the behavior you'd expect if you're +** trying to get user input at load time! **************************************************************************/ static void accept(FICL_VM *pVM) { - UNS32 count, len; + FICL_INT count; char *cp; - char *pBuf = vmGetInBuf(pVM); + char *pBuf = vmGetInBuf(pVM); + char *pEnd = vmGetInBufEnd(pVM); + FICL_INT len = pEnd - 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 */ - count = stackPopUNS32(pVM->pStack); + + /* + ** Now we have something in the text buffer - use it + */ + count = stackPopINT(pVM->pStack); cp = stackPopPtr(pVM->pStack); - strncpy(cp, vmGetInBuf(pVM), count); len = (count < len) ? count : len; + strncpy(cp, vmGetInBuf(pVM), len); pBuf += len; vmUpdateTib(pVM, pBuf); - stackPushUNS32(pVM->pStack, len); + stackPushINT(pVM->pStack, len); return; } @@ -2551,7 +2553,7 @@ static void aligned(FICL_VM *pVM) static void beginCoIm(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); - markBranch(dp, pVM, beginTag); + markBranch(dp, pVM, destTag); return; } @@ -2562,7 +2564,7 @@ static void untilCoIm(FICL_VM *pVM) assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); - resolveBackBranch(dp, pVM, beginTag); + resolveBackBranch(dp, pVM, destTag); return; } @@ -2573,9 +2575,9 @@ static void whileCoIm(FICL_VM *pVM) assert(pIfParen); dictAppendCell(dp, LVALUEtoCELL(pIfParen)); - markBranch(dp, pVM, whileTag); + markBranch(dp, pVM, origTag); twoSwap(pVM); - dictAppendUNS32(dp, 1); + dictAppendUNS(dp, 1); return; } @@ -2587,9 +2589,9 @@ static void repeatCoIm(FICL_VM *pVM) dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); /* expect "begin" branch marker */ - resolveBackBranch(dp, pVM, beginTag); + resolveBackBranch(dp, pVM, destTag); /* expect "while" branch marker */ - resolveForwardBranch(dp, pVM, whileTag); + resolveForwardBranch(dp, pVM, origTag); return; } @@ -2611,7 +2613,7 @@ static void repeatCoIm(FICL_VM *pVM) static void ficlChar(FICL_VM *pVM) { STRINGINFO si = vmGetWord(pVM); - stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0])); + stackPushUNS(pVM->pStack, (FICL_UNS)(si.cp[0])); return; } @@ -2649,8 +2651,8 @@ static void ficlChars(FICL_VM *pVM) { if (sizeof (char) > 1) { - INT32 i = stackPopINT32(pVM->pStack); - stackPushINT32(pVM->pStack, i * sizeof (char)); + FICL_INT i = stackPopINT(pVM->pStack); + stackPushINT(pVM->pStack, i * sizeof (char)); } /* otherwise no-op! */ return; @@ -2672,7 +2674,7 @@ static void count(FICL_VM *pVM) { FICL_STRING *sp = stackPopPtr(pVM->pStack); stackPushPtr(pVM->pStack, sp->text); - stackPushUNS32(pVM->pStack, sp->count); + stackPushUNS(pVM->pStack, sp->count); return; } @@ -2692,22 +2694,24 @@ static void count(FICL_VM *pVM) static void environmentQ(FICL_VM *pVM) { FICL_DICT *envp = ficlGetEnv(); - FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack); + FICL_COUNT len = (FICL_COUNT)stackPopUNS(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); FICL_WORD *pFW; STRINGINFO si; + + &len; /* silence compiler warning... */ SI_PSZ(si, cp); pFW = dictLookup(envp, si); if (pFW != NULL) { vmExecute(pVM, pFW); - stackPushINT32(pVM->pStack, FICL_TRUE); + stackPushINT(pVM->pStack, FICL_TRUE); } else { - stackPushINT32(pVM->pStack, FICL_FALSE); + stackPushINT(pVM->pStack, FICL_FALSE); } return; @@ -2722,24 +2726,21 @@ static void environmentQ(FICL_VM *pVM) ** 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 restarts. Also, exceptions -** are just passed ahead. Is this the Right Thing? I don't know... **************************************************************************/ static void evaluate(FICL_VM *pVM) { - INT32 count = stackPopINT32(pVM->pStack); + FICL_INT count = stackPopINT(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); CELL id; int result; id = pVM->sourceID; pVM->sourceID.i = -1; - vmPushIP(pVM, &pInterpret); - result = ficlExec(pVM, cp, count); - vmPopIP(pVM); + result = ficlExecC(pVM, cp, count); pVM->sourceID = id; if (result != VM_OUTOFTEXT) - vmThrow(pVM, result); + vmThrow(pVM, result); + return; } @@ -2761,7 +2762,7 @@ static void stringQuoteIm(FICL_VM *pVM) FICL_STRING *sp = (FICL_STRING *) dp->here; vmGetString(pVM, sp, '\"'); stackPushPtr(pVM->pStack, sp->text); - stackPushUNS32(pVM->pStack, sp->count); + stackPushUNS(pVM->pStack, sp->count); } else /* COMPILE state */ { @@ -2779,7 +2780,7 @@ static void stringQuoteIm(FICL_VM *pVM) **************************************************************************/ static void type(FICL_VM *pVM) { - UNS32 count = stackPopUNS32(pVM->pStack); + FICL_UNS count = stackPopUNS(pVM->pStack); char *cp = stackPopPtr(pVM->pStack); char *pDest = (char *)ficlMalloc(count + 1); @@ -2817,7 +2818,7 @@ static void type(FICL_VM *pVM) static void ficlWord(FICL_VM *pVM) { FICL_STRING *sp = (FICL_STRING *)pVM->pad; - char delim = (char)stackPopINT32(pVM->pStack); + char delim = (char)stackPopINT(pVM->pStack); STRINGINFO si; si = vmParseString(pVM, delim); @@ -2845,7 +2846,7 @@ static void parseNoCopy(FICL_VM *pVM) { STRINGINFO si = vmGetWord0(pVM); stackPushPtr(pVM->pStack, SI_PTR(si)); - stackPushUNS32(pVM->pStack, SI_COUNT(si)); + stackPushUNS(pVM->pStack, SI_COUNT(si)); return; } @@ -2862,23 +2863,26 @@ static void parseNoCopy(FICL_VM *pVM) static void parse(FICL_VM *pVM) { char *pSrc = vmGetInBuf(pVM); + char *pEnd = vmGetInBufEnd(pVM); char *cp; - UNS32 count; - char delim = (char)stackPopINT32(pVM->pStack); + FICL_UNS count; + char delim = (char)stackPopINT(pVM->pStack); cp = pSrc; /* mark start of text */ - while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0')) + while ((pSrc != pEnd) && (*pSrc != delim)) + { pSrc++; /* find next delimiter or end */ + } count = pSrc - cp; /* set length of result */ - if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */ + if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */ pSrc++; vmUpdateTib(pVM, pSrc); stackPushPtr(pVM->pStack, cp); - stackPushUNS32(pVM->pStack, count); + stackPushUNS(pVM->pStack, count); return; } @@ -2891,8 +2895,8 @@ static void parse(FICL_VM *pVM) **************************************************************************/ static void fill(FICL_VM *pVM) { - char ch = (char)stackPopINT32(pVM->pStack); - UNS32 u = stackPopUNS32(pVM->pStack); + char ch = (char)stackPopINT(pVM->pStack); + FICL_UNS u = stackPopUNS(pVM->pStack); char *cp = (char *)stackPopPtr(pVM->pStack); while (u > 0) @@ -2926,12 +2930,12 @@ static void find(FICL_VM *pVM) if (pFW) { stackPushPtr(pVM->pStack, pFW); - stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); + stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); } else { stackPushPtr(pVM->pStack, sp); - stackPushUNS32(pVM->pStack, 0); + stackPushUNS(pVM->pStack, 0); } return; } @@ -2947,15 +2951,15 @@ static void find(FICL_VM *pVM) **************************************************************************/ static void fmSlashMod(FICL_VM *pVM) { - INT64 d1; - INT32 n1; + DPINT d1; + FICL_INT n1; INTQR qr; - n1 = stackPopINT32(pVM->pStack); + n1 = stackPopINT(pVM->pStack); d1 = i64Pop(pVM->pStack); qr = m64FlooredDivI(d1, n1); - stackPushINT32(pVM->pStack, qr.rem); - stackPushINT32(pVM->pStack, qr.quot); + stackPushINT(pVM->pStack, qr.rem); + stackPushINT(pVM->pStack, qr.quot); return; } @@ -2970,30 +2974,30 @@ static void fmSlashMod(FICL_VM *pVM) **************************************************************************/ static void smSlashRem(FICL_VM *pVM) { - INT64 d1; - INT32 n1; + DPINT d1; + FICL_INT n1; INTQR qr; - n1 = stackPopINT32(pVM->pStack); + n1 = stackPopINT(pVM->pStack); d1 = i64Pop(pVM->pStack); qr = m64SymmetricDivI(d1, n1); - stackPushINT32(pVM->pStack, qr.rem); - stackPushINT32(pVM->pStack, qr.quot); + stackPushINT(pVM->pStack, qr.rem); + stackPushINT(pVM->pStack, qr.quot); return; } static void ficlMod(FICL_VM *pVM) { - INT64 d1; - INT32 n1; + DPINT d1; + FICL_INT n1; INTQR qr; - n1 = stackPopINT32(pVM->pStack); - d1.lo = stackPopINT32(pVM->pStack); + n1 = stackPopINT(pVM->pStack); + d1.lo = stackPopINT(pVM->pStack); i64Extend(d1); qr = m64SymmetricDivI(d1, n1); - stackPushINT32(pVM->pStack, qr.rem); + stackPushINT(pVM->pStack, qr.rem); return; } @@ -3008,15 +3012,15 @@ static void ficlMod(FICL_VM *pVM) *************************************************************************/ static void umSlashMod(FICL_VM *pVM) { - UNS64 ud; - UNS32 u1; + DPUNS ud; + FICL_UNS u1; UNSQR qr; - u1 = stackPopUNS32(pVM->pStack); + u1 = stackPopUNS(pVM->pStack); ud = u64Pop(pVM->pStack); qr = ficlLongDiv(ud, u1); - stackPushUNS32(pVM->pStack, qr.rem); - stackPushUNS32(pVM->pStack, qr.quot); + stackPushUNS(pVM->pStack, qr.rem); + stackPushUNS(pVM->pStack, qr.quot); return; } @@ -3037,20 +3041,20 @@ static void umSlashMod(FICL_VM *pVM) **************************************************************************/ static void lshift(FICL_VM *pVM) { - UNS32 nBits = stackPopUNS32(pVM->pStack); - UNS32 x1 = stackPopUNS32(pVM->pStack); + FICL_UNS nBits = stackPopUNS(pVM->pStack); + FICL_UNS x1 = stackPopUNS(pVM->pStack); - stackPushUNS32(pVM->pStack, x1 << nBits); + stackPushUNS(pVM->pStack, x1 << nBits); return; } static void rshift(FICL_VM *pVM) { - UNS32 nBits = stackPopUNS32(pVM->pStack); - UNS32 x1 = stackPopUNS32(pVM->pStack); + FICL_UNS nBits = stackPopUNS(pVM->pStack); + FICL_UNS x1 = stackPopUNS(pVM->pStack); - stackPushUNS32(pVM->pStack, x1 >> nBits); + stackPushUNS(pVM->pStack, x1 >> nBits); return; } @@ -3062,9 +3066,9 @@ static void rshift(FICL_VM *pVM) **************************************************************************/ static void mStar(FICL_VM *pVM) { - INT32 n2 = stackPopINT32(pVM->pStack); - INT32 n1 = stackPopINT32(pVM->pStack); - INT64 d; + FICL_INT n2 = stackPopINT(pVM->pStack); + FICL_INT n1 = stackPopINT(pVM->pStack); + DPINT d; d = m64MulI(n1, n2); i64Push(pVM->pStack, d); @@ -3074,9 +3078,9 @@ static void mStar(FICL_VM *pVM) static void umStar(FICL_VM *pVM) { - UNS32 u2 = stackPopUNS32(pVM->pStack); - UNS32 u1 = stackPopUNS32(pVM->pStack); - UNS64 ud; + FICL_UNS u2 = stackPopUNS(pVM->pStack); + FICL_UNS u1 = stackPopUNS(pVM->pStack); + DPUNS ud; ud = ficlLongMul(u1, u2); u64Push(pVM->pStack, ud); @@ -3090,19 +3094,19 @@ static void umStar(FICL_VM *pVM) **************************************************************************/ static void ficlMax(FICL_VM *pVM) { - INT32 n2 = stackPopINT32(pVM->pStack); - INT32 n1 = stackPopINT32(pVM->pStack); + FICL_INT n2 = stackPopINT(pVM->pStack); + FICL_INT n1 = stackPopINT(pVM->pStack); - stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2); + stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2); return; } static void ficlMin(FICL_VM *pVM) { - INT32 n2 = stackPopINT32(pVM->pStack); - INT32 n1 = stackPopINT32(pVM->pStack); + FICL_INT n2 = stackPopINT(pVM->pStack); + FICL_INT n1 = stackPopINT(pVM->pStack); - stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2); + stackPushINT(pVM->pStack, (n1 < n2) ? n1 : n2); return; } @@ -3119,7 +3123,7 @@ static void ficlMin(FICL_VM *pVM) **************************************************************************/ static void move(FICL_VM *pVM) { - UNS32 u = stackPopUNS32(pVM->pStack); + FICL_UNS u = stackPopUNS(pVM->pStack); char *addr2 = stackPopPtr(pVM->pStack); char *addr1 = stackPopPtr(pVM->pStack); @@ -3168,11 +3172,11 @@ static void recurseCoIm(FICL_VM *pVM) **************************************************************************/ static void sToD(FICL_VM *pVM) { - INT32 s = stackPopINT32(pVM->pStack); + FICL_INT s = stackPopINT(pVM->pStack); /* sign extend to 64 bits.. */ - stackPushINT32(pVM->pStack, s); - stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0); + stackPushINT(pVM->pStack, s); + stackPushINT(pVM->pStack, (s < 0) ? -1 : 0); return; } @@ -3187,8 +3191,7 @@ static void source(FICL_VM *pVM) { int i; stackPushPtr(pVM->pStack, pVM->tib.cp); - for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++); - stackPushINT32(pVM->pStack, i); + stackPushINT(pVM->pStack, vmGetInBufLen(pVM)); return; } @@ -3287,7 +3290,7 @@ static void getOrder(FICL_VM *pVM) stackPushPtr(pVM->pStack, pDict->pSearch[i]); } - stackPushUNS32(pVM->pStack, nLists); + stackPushUNS(pVM->pStack, nLists); ficlLockDictionary(FALSE); return; } @@ -3308,7 +3311,7 @@ static void searchWordlist(FICL_VM *pVM) FICL_WORD *pFW; FICL_HASH *pHash = stackPopPtr(pVM->pStack); - si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack); + si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); si.cp = stackPopPtr(pVM->pStack); hashCode = hashHashCode(si); @@ -3319,11 +3322,11 @@ static void searchWordlist(FICL_VM *pVM) if (pFW) { stackPushPtr(pVM->pStack, pFW); - stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); + stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); } else { - stackPushUNS32(pVM->pStack, 0); + stackPushUNS(pVM->pStack, 0); } return; @@ -3360,7 +3363,7 @@ static void setCurrent(FICL_VM *pVM) static void setOrder(FICL_VM *pVM) { int i; - int nLists = stackPopINT32(pVM->pStack); + int nLists = stackPopINT(pVM->pStack); FICL_DICT *dp = ficlGetDict(); if (nLists > FICL_DEFAULT_VOCS) @@ -3407,12 +3410,12 @@ static void wordlist(FICL_VM *pVM) { FICL_DICT *dp = ficlGetDict(); FICL_HASH *pHash; - UNS32 nBuckets; + FICL_UNS nBuckets; #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - nBuckets = stackPopUNS32(pVM->pStack); + nBuckets = stackPopUNS(pVM->pStack); dictAlign(dp); pHash = (FICL_HASH *)dp->here; @@ -3511,7 +3514,7 @@ static void colonNoName(FICL_VM *pVM) #if FICL_WANT_USER static void userParen(FICL_VM *pVM) { - INT32 i = pVM->runningWord->param[0].i; + FICL_INT i = pVM->runningWord->param[0].i; stackPushPtr(pVM->pStack, &pVM->user[i]); return; } @@ -3595,7 +3598,7 @@ static void toValue(FICL_VM *pVM) **************************************************************************/ static void linkParen(FICL_VM *pVM) { - INT32 nLink = *(INT32 *)(pVM->ip); + FICL_INT nLink = *(FICL_INT *)(pVM->ip); vmBranchRelative(pVM, 1); stackLink(pVM->rStack, nLink); return; @@ -3617,7 +3620,7 @@ static void unlinkParen(FICL_VM *pVM) **************************************************************************/ static void getLocalParen(FICL_VM *pVM) { - INT32 nLocal = *(INT32 *)(pVM->ip++); + FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); return; } @@ -3625,7 +3628,7 @@ static void getLocalParen(FICL_VM *pVM) static void toLocalParen(FICL_VM *pVM) { - INT32 nLocal = *(INT32 *)(pVM->ip++); + FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); return; } @@ -3725,7 +3728,7 @@ static void localParen(FICL_VM *pVM) static CELL *pMark = NULL; FICL_DICT *pDict = ficlGetDict(); STRINGINFO si; - SI_SETLEN(si, stackPopUNS32(pVM->pStack)); + SI_SETLEN(si, stackPopUNS(pVM->pStack)); SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); if (SI_COUNT(si) > 0) @@ -3762,7 +3765,7 @@ static void localParen(FICL_VM *pVM) } else if (nLocals > 0) { /* write nLocals to (link) param area in dictionary */ - *(INT32 *)pMark = nLocals; + *(FICL_INT *)pMark = nLocals; } return; @@ -3815,7 +3818,6 @@ int isAFiclWord(FICL_WORD *pFW) static int isAFiclWord(FICL_WORD *pFW) #endif { - void *pv = (void *)pFW; FICL_DICT *pd = ficlGetDict(); if (!dictIncludes(pd, pFW)) @@ -3921,7 +3923,6 @@ static void seeColon(FICL_VM *pVM, CELL *pc) */ static void see(FICL_VM *pVM) { - FICL_DICT *pd = ficlGetDict(); FICL_WORD *pFW; tick(pVM); @@ -3991,13 +3992,13 @@ static void see(FICL_VM *pVM) static void compareString(FICL_VM *pVM) { char *cp1, *cp2; - UNS32 u1, u2, uMin; + FICL_UNS u1, u2, uMin; int n = 0; vmCheckStack(pVM, 4, 1); - u2 = stackPopUNS32(pVM->pStack); + u2 = stackPopUNS(pVM->pStack); cp2 = (char *)stackPopPtr(pVM->pStack); - u1 = stackPopUNS32(pVM->pStack); + u1 = stackPopUNS(pVM->pStack); cp1 = (char *)stackPopPtr(pVM->pStack); uMin = (u1 < u2)? u1 : u2; @@ -4014,7 +4015,7 @@ static void compareString(FICL_VM *pVM) else if (n > 0) n = 1; - stackPushINT32(pVM->pStack, n); + stackPushINT(pVM->pStack, n); return; } @@ -4034,8 +4035,8 @@ static void compareString(FICL_VM *pVM) **************************************************************************/ static void refill(FICL_VM *pVM) { - INT32 ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; - stackPushINT32(pVM->pStack, ret); + FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; + stackPushINT(pVM->pStack, ret); if (ret) vmThrow(pVM, VM_OUTOFTEXT); return; @@ -4080,194 +4081,6 @@ 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. @@ -4282,10 +4095,10 @@ static void pfopen(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 2, 1); #endif - (void)stackPopINT32(pVM->pStack); /* don't need count value */ + (void)stackPopINT(pVM->pStack); /* don't need count value */ p = stackPopPtr(pVM->pStack); fd = open(p, O_RDONLY); - stackPushINT32(pVM->pStack, fd); + stackPushINT(pVM->pStack, fd); return; } @@ -4300,7 +4113,7 @@ static void pfclose(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - fd = stackPopINT32(pVM->pStack); /* get fd */ + fd = stackPopINT(pVM->pStack); /* get fd */ if (fd != -1) close(fd); return; @@ -4318,13 +4131,13 @@ static void pfread(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 3, 1); #endif - len = stackPopINT32(pVM->pStack); /* get number of bytes to read */ + len = stackPopINT(pVM->pStack); /* get number of bytes to read */ buf = stackPopPtr(pVM->pStack); /* get buffer */ - fd = stackPopINT32(pVM->pStack); /* get fd */ + fd = stackPopINT(pVM->pStack); /* get fd */ if (len > 0 && buf && fd != -1) - stackPushINT32(pVM->pStack, read(fd, buf, len)); + stackPushINT(pVM->pStack, read(fd, buf, len)); else - stackPushINT32(pVM->pStack, -1); + stackPushINT(pVM->pStack, -1); return; } @@ -4339,7 +4152,7 @@ static void pfload(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 0); #endif - fd = stackPopINT32(pVM->pStack); /* get fd */ + fd = stackPopINT(pVM->pStack); /* get fd */ if (fd != -1) ficlExecFD(pVM, fd); return; @@ -4354,7 +4167,7 @@ static void key(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 0, 1); #endif - stackPushINT32(pVM->pStack, getchar()); + stackPushINT(pVM->pStack, getchar()); return; } @@ -4369,10 +4182,10 @@ static void keyQuestion(FICL_VM *pVM) #endif #ifdef TESTMAIN /* XXX Since we don't fiddle with termios, let it always succeed... */ - stackPushINT32(pVM->pStack, FICL_TRUE); + stackPushINT(pVM->pStack, FICL_TRUE); #else /* But here do the right thing. */ - stackPushINT32(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE); + stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE); #endif return; } @@ -4391,7 +4204,7 @@ static void pseconds(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM,0,1); #endif - stackPushUNS32(pVM->pStack, (u_int32_t) time(NULL)); + stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL)); return; } @@ -4406,9 +4219,9 @@ static void ms(FICL_VM *pVM) vmCheckStack(pVM,1,0); #endif #ifdef TESTMAIN - usleep(stackPopUNS32(pVM->pStack)*1000); + usleep(stackPopUNS(pVM->pStack)*1000); #else - delay(stackPopUNS32(pVM->pStack)*1000); + delay(stackPopUNS(pVM->pStack)*1000); #endif return; } @@ -4425,9 +4238,229 @@ static void fkey(FICL_VM *pVM) #if FICL_ROBUST > 1 vmCheckStack(pVM, 1, 1); #endif - fd = stackPopINT32(pVM->pStack); + fd = stackPopINT(pVM->pStack); i = read(fd, &ch, 1); - stackPushINT32(pVM->pStack, i > 0 ? ch : -1); + stackPushINT(pVM->pStack, i > 0 ? ch : -1); + return; +} + +/************************************************************************** + freebsd exception handling words +** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE +** the word in ToS. If an exception happens, restore the state to what +** it was before, and pushes the exception value on the stack. If not, +** push zero. +** +** Notice that Catch implements an inner interpreter. This is ugly, +** but given how ficl works, it cannot be helped. The problem is that +** colon definitions will be executed *after* the function returns, +** while "code" definitions will be executed immediately. I considered +** other solutions to this problem, but all of them shared the same +** basic problem (with added disadvantages): if ficl ever changes it's +** inner thread modus operandi, one would have to fix this word. +** +** More comments can be found throughout catch's code. +** +** BUGS: do not handle locals unnesting correctly... I think... +** +** Daniel C. Sobral Jan 09/1999 +**************************************************************************/ + +static void ficlCatch(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 */ + stackPushINT(pVM->pStack, except); + + } + else /* Things being ok... */ + { + /* + * We need to know when to exit the inner loop + * Colonp, the "code" for colon words, just pushes + * the word's IP onto the RP, and expect the inner + * interpreter to do the rest. Well, I'd rather have + * it done *before* I return from this function, + * losing the automatic variables I'm using to save + * state. Sure, I could save this on dynamic memory + * and save state on RP, or I could even implement + * the poor man's version of this word in Forth with + * sp@, sp!, rp@ and rp!, but we have a lot of state + * neatly tucked away in pVM, so why not save it? + */ + exitIP = pVM->ip; + + /* Execute the xt -- inline code for vmExecute */ + + pVM->runningWord = pFW; + pFW->code(pVM); + + /* + ** Run the inner loop until we get back to exitIP + */ + for (; pVM->ip != exitIP;) + { + pFW = *pVM->ip++; + + /* Inline code for vmExecute */ + pVM->runningWord = pFW; + pFW->code(pVM); + } + + + /* Restore just the setjmp vector */ + pVM->pState = VM.pState; + + /* Push 0 -- everything is ok */ + stackPushINT(pVM->pStack, 0); + } +} + +/* + * Throw -- From ANS Forth standard. + * + * Throw takes the ToS and, if that's different from zero, + * returns to the last executed catch context. Further throws will + * unstack previously executed "catches", in LIFO mode. + * + * Daniel C. Sobral Jan 09/1999 + */ + +static void ficlThrow(FICL_VM *pVM) +{ + int except; + + except = stackPopINT(pVM->pStack); + + if (except) + vmThrow(pVM, except); +} + + +/*************** freebsd added memory-alloc handling words ******************/ + +static void ansAllocate(FICL_VM *pVM) +{ + size_t size; + void *p; + + size = stackPopINT(pVM->pStack); + p = ficlMalloc(size); + stackPushPtr(pVM->pStack, p); + if (p) + stackPushINT(pVM->pStack, 0); + else + stackPushINT(pVM->pStack, 1); +} + + +static void ansFree(FICL_VM *pVM) +{ + void *p; + + p = stackPopPtr(pVM->pStack); + ficlFree(p); + stackPushINT(pVM->pStack, 0); +} + + +static void ansResize(FICL_VM *pVM) +{ + size_t size; + void *new, *old; + + size = stackPopINT(pVM->pStack); + old = stackPopPtr(pVM->pStack); + new = ficlRealloc(old, size); + if (new) + { + stackPushPtr(pVM->pStack, new); + stackPushINT(pVM->pStack, 0); + } + else + { + stackPushPtr(pVM->pStack, old); + stackPushINT(pVM->pStack, 1); + } +} + + +/* +** exit-inner +** Signals execXT that an inner loop has completed +*/ +static void ficlExitInner(FICL_VM *pVM) +{ + vmThrow(pVM, VM_INNEREXIT); +} + + +/************************************************************************** + d n e g a t e +** DOUBLE ( d1 -- d2 ) +** d2 is the negation of d1. +**************************************************************************/ +static void dnegate(FICL_VM *pVM) +{ + DPINT i = i64Pop(pVM->pStack); + i = m64Negate(i); + i64Push(pVM->pStack, i); + return; } @@ -4440,7 +4473,7 @@ static void ficlTrace(FICL_VM *pVM) vmCheckStack(pVM, 1, 1); #endif - ficl_trace = stackPopINT32(pVM->pStack); + ficl_trace = stackPopINT(pVM->pStack); } #endif @@ -4619,23 +4652,6 @@ void ficlCompileCore(FICL_DICT *dp) #ifdef FICL_TRACE dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT); #endif - /* - ** 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__ @@ -4671,6 +4687,15 @@ void ficlCompileCore(FICL_DICT *dp) ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); /* + ** EXCEPTION word set + */ + dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); + dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); + + ficlSetEnv("exception", FICL_TRUE); + ficlSetEnv("exception-ext", FICL_TRUE); + + /* ** LOCAL and LOCAL EXT ** see softcore.c for implementation of locals| */ @@ -4700,6 +4725,17 @@ void ficlCompileCore(FICL_DICT *dp) #endif /* + ** Optional MEMORY-ALLOC word set + */ + + dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT); + dictAppendWord(dp, "free", ansFree, FW_DEFAULT); + dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); + + ficlSetEnv("memory-alloc", FICL_TRUE); + ficlSetEnv("memory-alloc-ext", FICL_FALSE); + + /* ** optional SEARCH-ORDER word set */ dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); @@ -4752,6 +4788,7 @@ void ficlCompileCore(FICL_DICT *dp) dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ dictAppendWord(dp, "compile-only", compileOnly, FW_DEFAULT); + dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); /* DOUBLE */ dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); @@ -4794,7 +4831,9 @@ 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, "exit-inner",ficlExitInner, FW_DEFAULT); + assert(dictCellsAvail(dp) > 0); return; } |
