d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add EXCEPTION word set.

Browse Source 
Make TIB handling use buffer size to conform with ANS Forth.

Add ANS MEMORY-ALLOC word set.

See the PRs for extensive details.

PR:		kern/9412 kern/9442 kern/9514
Submitted by:	PRs from Daniel Sobral <dcs@newsguy.com>
This commit is contained in:
Mike Smith 1999-01-22 23:52:59 +00:00
parent b7fd9e91ed
commit 6a80a16d7d
13 changed files with 339 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
sys/boot/ficl/alpha/sysdep.c
View File

@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
return malloc(size);
}
void *ficlRealloc (void *p, size_t size)
{
return realloc(p, size);
}
void ficlFree (void *p)
{
free(p);
}
#ifndef TESTMAIN
#ifdef __i386__
/*
* outb ( port# c -- )
@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
stackPushINT32(pVM->pStack,c);
}
#endif
#endif
/*
** Stub function for dictionary access control - does nothing

1
sys/boot/ficl/alpha/sysdep.h
View File

@ -215,6 +215,7 @@ typedef struct
struct vm;
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
void *ficlMalloc (size_t size);
void *ficlRealloc (void *p, size_t size);
void ficlFree (void *p);
/*

11
sys/boot/ficl/ficl.c
View File

@ -170,7 +170,7 @@ int ficlBuild(char *name, FICL_CODE code, char flags)
** time to delete the vm, etc -- or you can ignore this
** signal.
**************************************************************************/
int ficlExec(FICL_VM *pVM, char *pText)
int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
{
int except;
FICL_WORD *tempFW;
@ -180,7 +180,7 @@ int ficlExec(FICL_VM *pVM, char *pText)
assert(pVM);
vmPushTib(pVM, pText, &saveTib);
vmPushTib(pVM, pText, size, &saveTib);
/*
** Save and restore VM's jmp_buf to enable nested calls to ficlExec
@ -237,6 +237,8 @@ int ficlExec(FICL_VM *pVM, char *pText)
break;
case VM_ERREXIT:
case VM_ABORT:
case VM_ABORTQ:
default: /* user defined exit code?? */
if (pVM->state == COMPILE)
{
@ -285,8 +287,7 @@ int ficlExecFD(FICL_VM *pVM, int fd)
break;
continue;
}
cp[i] = '\0';
if ((rval = ficlExec(pVM, cp)) >= VM_ERREXIT)
if ((rval = ficlExec(pVM, cp, i)) >= VM_ERREXIT)
{
pVM->sourceID = id;
vmThrowErr(pVM, "ficlExecFD: Error at line %d", nLine);
@ -298,7 +299,7 @@ int ficlExecFD(FICL_VM *pVM, int fd)
** any pending REFILLs (as required by FILE wordset)
*/
pVM->sourceID.i = -1;
ficlExec(pVM, "");
ficlExec(pVM, "", 0);
pVM->sourceID = id;
return rval;

54
sys/boot/ficl/ficl.h
View File

@ -114,6 +114,19 @@
** 4. Ficl uses the pad in CORE words - this violates the standard,
** but it's cleaner for a multithreaded system. I'll have to make a
** second pad for reference by the word PAD to fix this.
** 5. The whole inner interpreter is screwed up. It ought to be detached
** from ficlExec. Also, it should fall in line with exception
** handling by saving state. (sobral)
** 6. EXCEPTION should be cleaned. Right now, it doubles ficlExec's
** inner interpreter. (sobral)
** 7. colonParen must get the inner interpreter working on it's "case"
** *before* returning, so that it becomes possible to execute them
** inside other definitions without recreating the inner interpreter
** or other such hacks. (sobral)
** 8. We now have EXCEPTION word set. Let's:
** 8.1. Use the appropriate exceptions throughout the code.
** 8.2. Print the error messages at ficlExec, so someone can catch
** them first. (sobral)
**
** F o r M o r e I n f o r m a t i o n
**
@ -153,6 +166,15 @@
/*
** Revision History:
**
** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an
** "end" field, and all words respect this. ficlExec is passed a "size"
** of TIB, as well as vmPushTib. This size is used to calculate the "end"
** of the string, ie, base+size. If the size is not known, pass -1.
**
** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing
** words has been modified to conform to EXCEPTION EXT word set.
**
** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT,
** SEARCH / SEARCH EXT, TOOLS / TOOLS EXT.
** Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD,
@ -292,10 +314,19 @@ typedef struct
** the block of text it's working on and an index to the next
** unconsumed character in the string. Traditionally, this is
** done by a Text Input Buffer, so I've called this struct TIB.
**
** Since this structure also holds the size of the input buffer,
** and since evaluate requires that, let's put the size here.
** The size is stored as an end-pointer because that is what the
** null-terminated string aware functions find most easy to deal
** with.
** Notice, though, that nobody really uses this except evaluate,
** so it might just be moved to FICL_VM instead. (sobral)
*/
typedef struct
{
INT32 index;
char *end;
char *cp;
} TIB;
@ -470,11 +501,13 @@ int wordIsCompileOnly(FICL_WORD *pFW);
/*
** Exit codes for vmThrow
*/
#define VM_OUTOFTEXT 1 /* hungry - normal exit */
#define VM_RESTART 2 /* word needs more text to suxcceed - re-run it */
#define VM_USEREXIT 3 /* user wants to quit */
#define VM_ERREXIT 4 /* interp found an error */
#define VM_QUIT 5 /* like errexit, but leave pStack & base alone */
#define VM_OUTOFTEXT -256 /* hungry - normal exit */
#define VM_RESTART -257 /* word needs more text to suxcceed - re-run it */
#define VM_USEREXIT -258 /* user wants to quit */
#define VM_ERREXIT -259 /* interp found an error */
#define VM_ABORT -1 /* like errexit -- abort */
#define VM_ABORTQ -2 /* like errexit -- abort" */
#define VM_QUIT -56 /* like errexit, but leave pStack & base alone */
void vmBranchRelative(FICL_VM *pVM, int offset);
@ -513,7 +546,7 @@ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
** PopTib restores the TIB state given a saved TIB from PushTib
** GetInBuf returns a pointer to the next unused char of the TIB
*/
void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib);
void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib);
void vmPopTib(FICL_VM *pVM, TIB *pTib);
#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
#define vmSetTibIndex(pVM, i) (pVM)->tib.index = i
@ -535,7 +568,7 @@ char *ltoa( INT32 value, char *string, int radix );
char *ultoa(UNS32 value, char *string, int radix );
char digit_to_char(int value);
char *strrev( char *string );
char *skipSpace(char *cp);
char *skipSpace(char *cp,char *end);
char *caseFold(char *cp);
int strincmp(char *cp1, char *cp2, FICL_COUNT count);
@ -677,7 +710,8 @@ void ficlTermSystem(void);
** f i c l E x e c
** Evaluates a block of input text in the context of the
** specified interpreter. Emits any requested output to the
** interpreter's output function
** interpreter's output function. If the size of the input
** is not known, pass -1.
** Execution returns when the text block has been executed,
** or an error occurs.
** Returns one of the VM_XXXX codes defined in ficl.h:
@ -689,10 +723,12 @@ void ficlTermSystem(void);
** to shut down the interpreter. This would be a good
** time to delete the vm, etc -- or you can ignore this
** signal.
** VM_ABORT and VM_ABORTQ are generated by 'abort' and 'abort"'
** commands.
** Preconditions: successful execution of ficlInitSystem,
** Successful creation and init of the VM by ficlNewVM (or equiv)
*/
int ficlExec(FICL_VM *pVM, char *pText);
int ficlExec(FICL_VM *pVM, char *pText, INT32 size);
/*
** ficlExecFD(FICL_VM *pVM, int fd);

7
sys/boot/ficl/i386/sysdep.c
View File

@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
return malloc(size);
}
void *ficlRealloc (void *p, size_t size)
{
return realloc(p, size);
}
void ficlFree (void *p)
{
free(p);
}
#ifndef TESTMAIN
#ifdef __i386__
/*
* outb ( port# c -- )
@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
stackPushINT32(pVM->pStack,c);
}
#endif
#endif
/*
** Stub function for dictionary access control - does nothing

1
sys/boot/ficl/i386/sysdep.h
View File

@ -215,6 +215,7 @@ typedef struct
struct vm;
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
void *ficlMalloc (size_t size);
void *ficlRealloc (void *p, size_t size);
void ficlFree (void *p);
/*

2
sys/boot/ficl/softwords/softcore.awk
View File

@ -91,6 +91,6 @@ END \
printf " \"quit \";\n";
printf "\n\nvoid ficlCompileSoftCore(FICL_VM *pVM)\n";
printf "{\n";
printf " assert(ficlExec(pVM, softWords) != VM_ERREXIT);\n";
printf " assert(ficlExec(pVM, softWords, -1) != VM_ERREXIT);\n";
printf "}\n";
}

4
sys/boot/ficl/softwords/softcore.fr
View File

@ -33,7 +33,9 @@ decimal 32 constant bl
postpone if
postpone ."
postpone cr
postpone abort
-2
postpone literal
postpone throw
postpone endif
; immediate

7
sys/boot/ficl/sysdep.c
View File

@ -66,11 +66,17 @@ void *ficlMalloc (size_t size)
return malloc(size);
}
void *ficlRealloc (void *p, size_t size)
{
return realloc(p, size);
}
void ficlFree (void *p)
{
free(p);
}
#ifndef TESTMAIN
#ifdef __i386__
/*
* outb ( port# c -- )
@ -102,6 +108,7 @@ ficlInb(FICL_VM *pVM)
stackPushINT32(pVM->pStack,c);
}
#endif
#endif
/*
** Stub function for dictionary access control - does nothing

1
sys/boot/ficl/sysdep.h
View File

@ -215,6 +215,7 @@ typedef struct
struct vm;
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
void *ficlMalloc (size_t size);
void *ficlRealloc (void *p, size_t size);
void ficlFree (void *p);
/*

15
sys/boot/ficl/testmain.c
View File

@ -144,11 +144,8 @@ static void ficlLoad(FICL_VM *pVM)
if (len <= 0)
continue;
if (cp[len] == '\n')
cp[len] = '\0';
result = ficlExec(pVM, cp);
if (result >= VM_ERREXIT)
result = ficlExec(pVM, cp, len);
if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
{
pVM->sourceID = id;
fclose(fp);
@ -161,7 +158,7 @@ static void ficlLoad(FICL_VM *pVM)
** any pending REFILLs (as required by FILE wordset)
*/
pVM->sourceID.i = -1;
ficlExec(pVM, "");
ficlExec(pVM, "", 0);
pVM->sourceID = id;
fclose(fp);
@ -246,7 +243,7 @@ int main(int argc, char **argv)
buildTestInterface();
pVM = ficlNewVM();
ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit", -1);
/*
** load file from cmd line...
@ -254,7 +251,7 @@ int main(int argc, char **argv)
if (argc > 1)
{
sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
ficlExec(pVM, in);
ficlExec(pVM, in, -1);
}
for (;;)
@ -262,7 +259,7 @@ int main(int argc, char **argv)
int ret;
if (fgets(in, sizeof(in) - 1, stdin) == NULL)
break;
ret = ficlExec(pVM, in);
ret = ficlExec(pVM, in, -1);
if (ret == VM_USEREXIT)
{
ficlTermSystem();

25
sys/boot/ficl/vm.c
View File

@ -156,17 +156,17 @@ STRINGINFO vmGetWord0(FICL_VM *pVM)
UNS32 count = 0;
char ch;
pSrc = skipSpace(pSrc);
pSrc = skipSpace(pSrc,pVM->tib.end);
SI_SETPTR(si, pSrc);
for (ch = *pSrc; ch != '\0' && !isspace(ch); ch = *++pSrc)
for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc)
{
count++;
}
SI_SETLEN(si, count);
if (isspace(ch)) /* skip one trailing delimiter */
if ((pVM->tib.end != pSrc) && isspace(ch)) /* skip one trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
@ -210,14 +210,15 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
{
STRINGINFO si;
char *pSrc = vmGetInBuf(pVM);
char ch;
char ch;
while (*pSrc == delim) /* skip lead delimiters */
while ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* skip lead delimiters */
pSrc++;
SI_SETPTR(si, pSrc); /* mark start of text */
for (ch = *pSrc; (ch != delim)
for (ch = *pSrc; (pVM->tib.end != pSrc)
&& (ch != delim)
&& (ch != '\0')
&& (ch != '\r')
&& (ch != '\n'); ch = *++pSrc)
@ -228,7 +229,7 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
/* set length of result */
SI_SETLEN(si, pSrc - SI_PTR(si));
if (*pSrc == delim) /* gobble trailing delimiter */
if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
@ -263,7 +264,7 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
v m P u s h T i b
** Binds the specified input string to the VM and clears >IN (the index)
**************************************************************************/
void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib)
void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib)
{
if (pSaveTib)
{
@ -271,6 +272,7 @@ void vmPushTib(FICL_VM *pVM, char *text, TIB *pSaveTib)
}
pVM->tib.cp = text;
pVM->tib.end = text + size;
pVM->tib.index = 0;
}
@ -302,6 +304,7 @@ void vmQuit(FICL_VM *pVM)
pVM->runningWord = pInterp;
pVM->state = INTERPRET;
pVM->tib.cp = NULL;
pVM->tib.end = NULL;
pVM->tib.index = 0;
pVM->pad[0] = '\0';
pVM->sourceID.i = 0;
@ -551,12 +554,14 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count)
s k i p S p a c e
** Given a string pointer, returns a pointer to the first non-space
** char of the string, or to the NULL terminator if no such char found.
** If the pointer reaches "end" first, stop there. If you don't want
** that, pass NULL.
**************************************************************************/
char *skipSpace(char *cp)
char *skipSpace(char *cp, char *end)
{
assert(cp);
while (isspace(*cp))
while ((cp != end) && isspace(*cp))
cp++;
return cp;

262
sys/boot/ficl/words.c
View File

@ -880,7 +880,7 @@ static void commentLine(FICL_VM *pVM)
char *cp = vmGetInBuf(pVM);
char ch = *cp;
while ((ch != '\0') && (ch != '\r') && (ch != '\n'))
while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n'))
{
ch = *++cp;
}
@ -890,11 +890,11 @@ static void commentLine(FICL_VM *pVM)
** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
** and point cp to next char. If EOL is \0, we're done.
*/
if (ch != '\0')
if ((pVM->tib.end != cp) && (ch != '\0'))
{
cp++;
if ( (ch != *cp)
if ( (pVM->tib.end != cp) && (ch != *cp)
&& ((*cp == '\r') || (*cp == '\n')) )
cp++;
}
@ -1180,13 +1180,10 @@ static void interpret(FICL_VM *pVM)
// Get next word...if out of text, we're done.
*/
if (si.count == 0)
{
vmThrow(pVM, VM_OUTOFTEXT);
}
interpWord(pVM, si);
return; /* back to inner interpreter */
}
@ -1234,7 +1231,6 @@ static void interpWord(FICL_VM *pVM, STRINGINFO si)
{
vmThrowErr(pVM, "Error: Compile only!");
}
vmExecute(pVM, tempFW);
}
@ -2069,13 +2065,13 @@ static void dotParen(FICL_VM *pVM)
char *pDest = pVM->pad;
char ch;
pSrc = skipSpace(pSrc);
pSrc = skipSpace(pSrc,pVM->tib.end);
for (ch = *pSrc; (ch != '\0') && (ch != ')'); ch = *++pSrc)
for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc)
*pDest++ = ch;
*pDest = '\0';
if (ch == ')')
if ((pVM->tib.end != pSrc) && (ch == ')'))
pSrc++;
vmTextOut(pVM, pVM->pad, 0);
@ -2441,7 +2437,7 @@ static void quit(FICL_VM *pVM)
static void ficlAbort(FICL_VM *pVM)
{
vmThrow(pVM, VM_ERREXIT);
vmThrow(pVM, VM_ABORT);
return;
}
@ -2462,6 +2458,10 @@ static void ficlAbort(FICL_VM *pVM)
** Implementation: if there's more text in the TIB, use it. Otherwise
** throw out for more text. Copy characters up to the max count into the
** address given, and return the number of actual characters copied.
**
** This may not strictly violate the standard, but I'm sure any programs
** asking for user input at load time will *not* be expecting this
** behavior. (sobral)
**************************************************************************/
static void accept(FICL_VM *pVM)
{
@ -2469,7 +2469,7 @@ static void accept(FICL_VM *pVM)
char *cp;
char *pBuf = vmGetInBuf(pVM);
len = strlen(pBuf);
for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++);
if (len == 0)
vmThrow(pVM, VM_RESTART);
/* OK - now we have something in the text buffer - use it */
@ -2692,25 +2692,28 @@ static void environmentQ(FICL_VM *pVM)
** EVALUATE CORE ( i*x c-addr u -- j*x )
** Save the current input source specification. Store minus-one (-1) in
** SOURCE-ID if it is present. Make the string described by c-addr and u
** both the input source and input buffer, set >IN to zero, and interpret.
** both the input source andinput buffer, set >IN to zero, and interpret.
** When the parse area is empty, restore the prior input source
** specification. Other stack effects are due to the words EVALUATEd.
**
** DEFICIENCY: this version does not handle errors or restarts.
** DEFICIENCY: this version does not handle restarts. Also, exceptions
** are just passed ahead. Is this the Right Thing? I don't know...
**************************************************************************/
static void evaluate(FICL_VM *pVM)
{
UNS32 count = stackPopUNS32(pVM->pStack);
INT32 count = stackPopINT32(pVM->pStack);
char *cp = stackPopPtr(pVM->pStack);
CELL id;
int result;
IGNORE(count);
id = pVM->sourceID;
pVM->sourceID.i = -1;
vmPushIP(pVM, &pInterpret);
ficlExec(pVM, cp);
result = ficlExec(pVM, cp, count);
vmPopIP(pVM);
pVM->sourceID = id;
if (result != VM_OUTOFTEXT)
vmThrow(pVM, result);
return;
}
@ -2843,12 +2846,12 @@ static void parse(FICL_VM *pVM)
cp = pSrc; /* mark start of text */
while ((*pSrc != delim) && (*pSrc != '\0'))
while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0'))
pSrc++; /* find next delimiter or end */
count = pSrc - cp; /* set length of result */
if (*pSrc == delim) /* gobble trailing delimiter */
if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
pSrc++;
vmUpdateTib(pVM, pSrc);
@ -3159,9 +3162,11 @@ static void sToD(FICL_VM *pVM)
** input buffer.
**************************************************************************/
static void source(FICL_VM *pVM)
{
{ int i;
stackPushPtr(pVM->pStack, pVM->tib.cp);
stackPushINT32(pVM->pStack, strlen(pVM->tib.cp));
for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++);
stackPushINT32(pVM->pStack, i);
return;
}
@ -4049,6 +4054,194 @@ static void forget(FICL_VM *pVM)
return;
}
/*************** freebsd added memory-alloc handling words ******************/
static void allocate(FICL_VM *pVM)
{
size_t size;
void *p;
size = stackPopINT32(pVM->pStack);
p = ficlMalloc(size);
stackPushPtr(pVM->pStack, p);
if (p)
stackPushINT32(pVM->pStack, 0);
else
stackPushINT32(pVM->pStack, 1);
}
static void free4th(FICL_VM *pVM)
{
void *p;
p = stackPopPtr(pVM->pStack);
ficlFree(p);
stackPushINT32(pVM->pStack, 0);
}
static void resize(FICL_VM *pVM)
{
size_t size;
void *new, *old;
size = stackPopINT32(pVM->pStack);
old = stackPopPtr(pVM->pStack);
new = ficlRealloc(old, size);
if (new) {
stackPushPtr(pVM->pStack, new);
stackPushINT32(pVM->pStack, 0);
} else {
stackPushPtr(pVM->pStack, old);
stackPushINT32(pVM->pStack, 1);
}
}
/***************** freebsd added exception handling words *******************/
/*
* Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
* the word in ToS. If an exception happens, restore the state to what
* it was before, and pushes the exception value on the stack. If not,
* push zero.
*
* Notice that Catch implements an inner interpreter. This is ugly,
* but given how ficl works, it cannot be helped. The problem is that
* colon definitions will be executed *after* the function returns,
* while "code" definitions will be executed immediately. I considered
* other solutions to this problem, but all of them shared the same
* basic problem (with added disadvantages): if ficl ever changes it's
* inner thread modus operandi, one would have to fix this word.
*
* More comments can be found throughout catch's code.
*
* BUGS: do not handle locals unnesting correctly... I think...
*
* Daniel C. Sobral Jan 09/1999
*/
static void catch(FICL_VM *pVM)
{
int except;
jmp_buf vmState;
FICL_VM VM;
FICL_STACK pStack;
FICL_STACK rStack;
FICL_WORD *pFW;
IPTYPE exitIP;
/*
* Get xt.
* We need this *before* we save the stack pointer, or
* we'll have to pop one element out of the stack after
* an exception. I prefer to get done with it up front. :-)
*/
#if FICL_ROBUST > 1
vmCheckStack(pVM, 1, 0);
#endif
pFW = stackPopPtr(pVM->pStack);
/*
* Save vm's state -- a catch will not back out environmental
* changes.
*
* We are *not* saving dictionary state, since it is
* global instead of per vm, and we are not saving
* stack contents, since we are not required to (and,
* thus, it would be useless). We save pVM, and pVM
* "stacks" (a structure containing general information
* about it, including the current stack pointer).
*/
memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
/*
* Give pVM a jmp_buf
*/
pVM->pState = &vmState;
/*
* Safety net
*/
except = setjmp(vmState);
/*
* And now, choose what to do depending on except.
*/
/* Things having gone wrong... */
if(except) {
/* Restore vm's state */
memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
/* Push error */
stackPushINT32(pVM->pStack, except);
/* Things being ok... */
} else {
/*
* We need to know when to exit the inner loop
* Colonp, the "code" for colon words, just pushes
* the word's IP onto the RP, and expect the inner
* interpreter to do the rest. Well, I'd rather have
* it done *before* I return from this function,
* losing the automatic variables I'm using to save
* state. Sure, I could save this on dynamic memory
* and save state on RP, or I could even implement
* the poor man's version of this word in Forth with
* sp@, sp!, rp@ and rp!, but we have a lot of state
* neatly tucked away in pVM, so why not save it?
*/
exitIP = pVM->ip;
/* Execute the xt -- inline code for vmExecute */
pVM->runningWord = pFW;
pFW->code(pVM);
/*
* Run the inner loop until we get back to exitIP
*/
for (; pVM->ip != exitIP;) {
pFW = *pVM->ip++;
/* Inline code for vmExecute */
pVM->runningWord = pFW;
pFW->code(pVM);
}
/* Restore just the setjmp vector */
pVM->pState = VM.pState;
/* Push 0 -- everything is ok */
stackPushINT32(pVM->pStack, 0);
}
}
/*
* Throw -- maybe vmThow already do what's required, but I don't really
* know what happens when you longjmp(buf, 0). From ANS Forth standard.
*
* Anyway, throw takes the ToS and, if that's different from zero,
* returns to the last executed catch context. Further throws will
* unstack previously executed "catches", in LIFO mode.
*
* Daniel C. Sobral Jan 09/1999
*/
static void throw(FICL_VM *pVM)
{
int except;
except = stackPopINT32(pVM->pStack);
if (except)
vmThrow(pVM, except);
}
/************************* freebsd added I/O words **************************/
/* fopen - open a file and return new fd on stack.
@ -4385,14 +4578,37 @@ void ficlCompileCore(FICL_DICT *dp)
dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
dictAppendWord(dp, "ms", ms, FW_DEFAULT);
dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
#ifdef __i386__
/*
** EXCEPTION word set
*/
dictAppendWord(dp, "catch", catch, FW_DEFAULT);
dictAppendWord(dp, "throw", throw, FW_DEFAULT);
ficlSetEnv("exception", FICL_TRUE);
ficlSetEnv("exception-ext", FICL_TRUE);
/*
** MEMORY-ALLOC word set
*/
dictAppendWord(dp, "allocate", allocate, FW_DEFAULT);
dictAppendWord(dp, "free", free4th, FW_DEFAULT);
dictAppendWord(dp, "resize", resize, FW_DEFAULT);
ficlSetEnv("memory-alloc", FICL_TRUE);
#ifndef TESTMAIN
#ifdef __i386__
dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT);
dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT);
#endif
#endif
#if defined(__i386__)
ficlSetEnv("arch-i386", FICL_TRUE);
#else
ficlSetEnv("arch-alpha", FICL_FALSE);
#elif defined(__alpha__)
ficlSetEnv("arch-i386", FICL_FALSE);
ficlSetEnv("arch-alpha", FICL_TRUE);
#endif
/*