From 5bf7a61bb35132fbb2385b4a60f016b0189da4d0 Mon Sep 17 00:00:00 2001 From: Jung-uk Kim Date: Fri, 23 Mar 2007 22:26:01 +0000 Subject: [PATCH] Update to FICL 3.03 (the last release before FICL4 rewrite). The relevant changes for FreeBSD (excerpt from the release note): * Newly implemented CORE EXT words: CASE, OF, ENDOF, and ENDCASE. Also added FALLTHROUGH, which works like ENDOF but jumps to the instruction just after the next OF. * Bugfix: John-Hopkins locals syntax now accepts | and -- in the comment (between the first -- and the }.) * Bugfix: Changed vmGetWord0() to make Purify happier. The resulting code is no slower, no larger, and slightly more robust. --- sys/boot/ficl/ficl.h | 9 +- sys/boot/ficl/float.c | 3 + sys/boot/ficl/softwords/fileaccess.fr | 3 +- sys/boot/ficl/softwords/jhlocal.fr | 19 +- sys/boot/ficl/softwords/oo.fr | 15 +- sys/boot/ficl/softwords/prefix.fr | 2 +- sys/boot/ficl/softwords/softcore.awk | 49 +++- sys/boot/ficl/tools.c | 11 +- sys/boot/ficl/unix.c | 6 +- sys/boot/ficl/vm.c | 16 +- sys/boot/ficl/words.c | 350 ++++++++++++++++++++++---- 11 files changed, 410 insertions(+), 73 deletions(-) diff --git a/sys/boot/ficl/ficl.h b/sys/boot/ficl/ficl.h index d10c850a9b7f..7892ee963d7f 100644 --- a/sys/boot/ficl/ficl.h +++ b/sys/boot/ficl/ficl.h @@ -237,9 +237,9 @@ typedef struct ficl_system_info FICL_SYSTEM_INFO; /* ** the Good Stuff starts here... */ -#define FICL_VER "3.02" +#define FICL_VER "3.03" #define FICL_VER_MAJOR 3 -#define FICL_VER_MINOR 2 +#define FICL_VER_MINOR 3 #if !defined (FICL_PROMPT) #define FICL_PROMPT "ok> " #endif @@ -857,7 +857,7 @@ struct ficl_system FICL_WORD *pDoesParen; FICL_WORD *pExitInner; FICL_WORD *pExitParen; - FICL_WORD *pIfParen; + FICL_WORD *pBranch0; FICL_WORD *pInterpret; FICL_WORD *pLitParen; FICL_WORD *pTwoLitParen; @@ -865,7 +865,9 @@ struct ficl_system FICL_WORD *pPLoopParen; FICL_WORD *pQDoParen; FICL_WORD *pSemiParen; + FICL_WORD *pOfParen; FICL_WORD *pStore; + FICL_WORD *pDrop; FICL_WORD *pCStringLit; FICL_WORD *pStringLit; @@ -1086,6 +1088,7 @@ typedef enum IF, LITERAL, LOOP, + OF, PLOOP, PRIMITIVE, QDO, diff --git a/sys/boot/ficl/float.c b/sys/boot/ficl/float.c index 3fe858147c8f..d757b23648bc 100644 --- a/sys/boot/ficl/float.c +++ b/sys/boot/ficl/float.c @@ -977,6 +977,8 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ) } PUSHFLOAT(accum); + if (pVM->state == COMPILE) + fliteralIm(pVM); return(1); } @@ -1062,3 +1064,4 @@ void ficlCompileFloat(FICL_SYSTEM *pSys) #endif return; } + diff --git a/sys/boot/ficl/softwords/fileaccess.fr b/sys/boot/ficl/softwords/fileaccess.fr index 10ec5bd72486..7297df681cf3 100644 --- a/sys/boot/ficl/softwords/fileaccess.fr +++ b/sys/boot/ficl/softwords/fileaccess.fr @@ -15,12 +15,11 @@ r/o bin open-file 0= if locals| f | end-locals f include-file - f close-file drop else drop endif ; -: include parse-word included ; immediate +: include parse-word included ; \ #endif diff --git a/sys/boot/ficl/softwords/jhlocal.fr b/sys/boot/ficl/softwords/jhlocal.fr index b6e84674c9fa..12ccb9fea753 100644 --- a/sys/boot/ficl/softwords/jhlocal.fr +++ b/sys/boot/ficl/softwords/jhlocal.fr @@ -17,8 +17,10 @@ \ $FreeBSD$ hide + 0 constant zero + : ?-- ( c-addr u -- c-addr u flag ) 2dup s" --" compare 0= ; : ?} ( c-addr u -- c-addr u flag ) @@ -74,23 +76,24 @@ set-current parse-word ?delim dup to locstate 0= while - ?2loc if - postpone zero postpone zero (2local) - else - postpone zero (local) - endif + ?2loc if + postpone zero postpone zero (2local) + else + postpone zero (local) + endif repeat endif 0 0 (local) \ toss words until } + \ (explicitly allow | and -- in the comment) locstate 2 = if begin parse-word - ?delim dup to locstate - 0= while - 2drop + ?delim dup to locstate + 3 < while + locstate 0= if 2drop endif repeat endif diff --git a/sys/boot/ficl/softwords/oo.fr b/sys/boot/ficl/softwords/oo.fr index 9e6a04ea24df..b1c8e214e5bd 100644 --- a/sys/boot/ficl/softwords/oo.fr +++ b/sys/boot/ficl/softwords/oo.fr @@ -86,8 +86,6 @@ user current-class \ execute it at run-time... \ -hide - \ p a r s e - m e t h o d \ compiles a method name so that it pushes \ the string base address and count at run-time. @@ -97,6 +95,13 @@ hide postpone sliteral ; compile-only + + +: (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } + class name class cell+ @ ( class c-addr u wid ) + search-wordlist +; + \ l o o k u p - m e t h o d \ takes a counted string method name from the stack (as compiled \ by parse-method) and attempts to look this method up in the method list of @@ -104,22 +109,18 @@ hide \ and pushes the xt of the method. If not, it aborts with an error message. : lookup-method { class 2:name -- class xt } - name class cell+ @ ( c-addr u wid ) - search-wordlist ( 0 | xt 1 | xt -1 ) + class name (lookup-method) ( 0 | xt 1 | xt -1 ) 0= if name type ." not found in " class body> >name type cr abort endif - class swap ; : find-method-xt \ name ( class -- class xt ) parse-word lookup-method ; -set-current ( stop hiding definitions ) - : catch-method ( instance class c-addr u -- exc-flag ) lookup-method catch ; diff --git a/sys/boot/ficl/softwords/prefix.fr b/sys/boot/ficl/softwords/prefix.fr index 53a1d540043d..ae1727fc00bc 100644 --- a/sys/boot/ficl/softwords/prefix.fr +++ b/sys/boot/ficl/softwords/prefix.fr @@ -22,7 +22,7 @@ start-prefixes \ make .( a prefix (we just create an alias for it in the prefixes list) -: .( .( ; +: .( postpone .( ; immediate \ make \ a prefix, and add // (same thing) as a prefix too diff --git a/sys/boot/ficl/softwords/softcore.awk b/sys/boot/ficl/softwords/softcore.awk index c41996aebeaa..5a97999a9823 100644 --- a/sys/boot/ficl/softwords/softcore.awk +++ b/sys/boot/ficl/softwords/softcore.awk @@ -14,21 +14,59 @@ BEGIN \ { - printf "/***************************************************************\n"; + printf "/*******************************************************************\n"; printf "** s o f t c o r e . c\n"; printf "** Forth Inspired Command Language -\n"; printf "** Words from CORE set written in FICL\n"; printf "** Author: John Sadler (john_sadler@alum.mit.edu)\n"; printf "** Created: 27 December 1997\n"; printf "** Last update: %s\n", datestamp; - printf "***************************************************************/\n"; - printf "\n/*\n"; + printf "*******************************************************************/\n"; + printf "/*\n"; + printf "** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.awk\n"; + printf "** Make changes to the .fr files in ficl/softwords instead.\n"; printf "** This file contains definitions that are compiled into the\n"; printf "** system dictionary by the first virtual machine to be created.\n"; printf "** Created automagically by ficl/softwords/softcore.awk\n"; printf "*/\n"; + printf "/*\n"; + printf "** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)\n"; + printf "** All rights reserved.\n"; + printf "**\n"; + printf "** Get the latest Ficl release at http://ficl.sourceforge.net\n"; + printf "**\n"; + printf "** I am interested in hearing from anyone who uses ficl. If you have\n"; + printf "** a problem, a success story, a defect, an enhancement request, or\n"; + printf "** if you would like to contribute to the ficl release, please send\n"; + printf "** contact me by email at the address above.\n"; + printf "**\n"; + printf "** L I C E N S E and D I S C L A I M E R\n"; + printf "** \n"; + printf "** Redistribution and use in source and binary forms, with or without\n"; + printf "** modification, are permitted provided that the following conditions\n"; + printf "** are met:\n"; + printf "** 1. Redistributions of source code must retain the above copyright\n"; + printf "** notice, this list of conditions and the following disclaimer.\n"; + printf "** 2. Redistributions in binary form must reproduce the above copyright\n"; + printf "** notice, this list of conditions and the following disclaimer in the\n"; + printf "** documentation and/or other materials provided with the distribution.\n"; + printf "**\n"; + printf "** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND\n"; + printf "** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n"; + printf "** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n"; + printf "** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE\n"; + printf "** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n"; + printf "** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n"; + printf "** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n"; + printf "** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n"; + printf "** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n"; + printf "** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n"; + printf "** SUCH DAMAGE.\n"; + printf "*/\n"; + printf "\n"; printf "\n#include \"ficl.h\"\n"; printf "\nstatic char softWords[] =\n"; + printf "#if FICL_WANT_SOFTWORDS\n"; commenting = 0; } @@ -127,14 +165,17 @@ function end_comments() END \ { if (commenting) end_comments(); + printf "#endif /* WANT_SOFTWORDS */\n"; printf " \"quit \";\n"; printf "\n\nvoid ficlCompileSoftCore(FICL_SYSTEM *pSys)\n"; printf "{\n"; printf " FICL_VM *pVM = pSys->vmList;\n"; + printf " CELL id = pVM->sourceID;\n"; printf " int ret = sizeof (softWords);\n"; printf " assert(pVM);\n"; - printf "\n" + printf " pVM->sourceID.i = -1;\n"; printf " ret = ficlExec(pVM, softWords);\n"; + printf " pVM->sourceID = id;\n"; printf " if (ret == VM_ERREXIT)\n"; printf " assert(FALSE);\n"; printf " return;\n"; diff --git a/sys/boot/ficl/tools.c b/sys/boot/ficl/tools.c index dc321f8cf2e3..02f9acf3c66b 100644 --- a/sys/boot/ficl/tools.c +++ b/sys/boot/ficl/tools.c @@ -244,10 +244,17 @@ static void seeColon(FICL_VM *pVM, CELL *pc) break; case BRANCH: c = *++pc; - if (c.i > 0) + if (c.i == 0) + sprintf(cp, "repeat (branch %d)", pc+c.i-param0); + else if (c.i == 1) sprintf(cp, "else (branch %d)", pc+c.i-param0); else - sprintf(cp, "repeat (branch %d)", pc+c.i-param0); + sprintf(cp, "endof (branch %d)", pc+c.i-param0); + break; + + case OF: + c = *++pc; + sprintf(cp, "of (branch %d)", pc+c.i-param0); break; case QDO: diff --git a/sys/boot/ficl/unix.c b/sys/boot/ficl/unix.c index 4400752f4f48..5b5644079ba9 100644 --- a/sys/boot/ficl/unix.c +++ b/sys/boot/ficl/unix.c @@ -8,9 +8,9 @@ unsigned long ficlNtohl(unsigned long number) - { - return ntohl(number); - } +{ + return ntohl(number); +} diff --git a/sys/boot/ficl/vm.c b/sys/boot/ficl/vm.c index 7bcb19a601f9..97a4f04e3b3b 100644 --- a/sys/boot/ficl/vm.c +++ b/sys/boot/ficl/vm.c @@ -316,15 +316,29 @@ STRINGINFO vmGetWord0(FICL_VM *pVM) char *pEnd = vmGetInBufEnd(pVM); STRINGINFO si; FICL_UNS count = 0; - char ch; + char ch = 0; pSrc = skipSpace(pSrc, pEnd); SI_SETPTR(si, pSrc); +/* for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc) { count++; } +*/ + + /* Changed to make Purify happier. --lch */ + for (;;) + { + if (pEnd == pSrc) + break; + ch = *pSrc; + if (isspace(ch)) + break; + count++; + pSrc++; + } SI_SETLEN(si, count); diff --git a/sys/boot/ficl/words.c b/sys/boot/ficl/words.c index 341993885baa..ddeb1af61c29 100644 --- a/sys/boot/ficl/words.c +++ b/sys/boot/ficl/words.c @@ -71,6 +71,10 @@ static char leaveTag[] = "leave"; static char destTag[] = "target"; static char origTag[] = "origin"; +static char caseTag[] = "case"; +static char ofTag[] = "of"; +static char fallthroughTag[] = "fallthrough"; + #if FICL_WANT_LOCALS static void doLocalIm(FICL_VM *pVM); static void do2LocalIm(FICL_VM *pVM); @@ -1220,34 +1224,26 @@ static void cStore(FICL_VM *pVM) /************************************************************************** - i f C o I m -** IMMEDIATE -** Compiles code for a conditional branch into the dictionary -** and pushes the branch patch address on the stack for later -** patching by ELSE or THEN/ENDIF. + b r a n c h P a r e n +** +** Runtime for "(branch)" -- expects a literal offset in the next +** compilation address, and branches to that location. **************************************************************************/ -static void ifCoIm(FICL_VM *pVM) +static void branchParen(FICL_VM *pVM) { - FICL_DICT *dp = vmGetDict(pVM); - - assert(pVM->pSys->pIfParen); - - dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); - markBranch(dp, pVM, origTag); - dictAppendUNS(dp, 1); + vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); return; } /************************************************************************** - i f P a r e n -** Runtime code to do "if" or "until": pop a flag from the stack, -** fall through if true, branch if false. Probably ought to be -** called (not?branch) since it does "branch if false". + b r a n c h 0 +** Runtime code for "(branch0)"; pop a flag from the stack, +** branch if 0. fall through otherwise. The heart of "if" and "until". **************************************************************************/ -static void ifParen(FICL_VM *pVM) +static void branch0(FICL_VM *pVM) { FICL_UNS flag; @@ -1269,10 +1265,32 @@ static void ifParen(FICL_VM *pVM) } +/************************************************************************** + i f C o I m +** IMMEDIATE COMPILE-ONLY +** Compiles code for a conditional branch into the dictionary +** and pushes the branch patch address on the stack for later +** patching by ELSE or THEN/ENDIF. +**************************************************************************/ + +static void ifCoIm(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + + assert(pVM->pSys->pBranch0); + + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); + markBranch(dp, pVM, origTag); + dictAppendUNS(dp, 1); + return; +} + + /************************************************************************** e l s e C o I m ** -** IMMEDIATE -- compiles an "else"... +** IMMEDIATE COMPILE-ONLY +** compiles an "else"... ** 1) Compile a branch and a patch address; the address gets patched ** by "endif" to point past the "else" code. ** 2) Pop the the "if" patch address @@ -1302,23 +1320,9 @@ static void elseCoIm(FICL_VM *pVM) } -/************************************************************************** - b r a n c h P a r e n -** -** Runtime for "(branch)" -- expects a literal offset in the next -** compilation address, and branches to that location. -**************************************************************************/ - -static void branchParen(FICL_VM *pVM) -{ - vmBranchRelative(pVM, (uintptr_t)*(pVM->ip)); - return; -} - - /************************************************************************** e n d i f C o I m -** +** IMMEDIATE COMPILE-ONLY **************************************************************************/ static void endifCoIm(FICL_VM *pVM) @@ -1329,6 +1333,234 @@ static void endifCoIm(FICL_VM *pVM) } +/************************************************************************** + c a s e C o I m +** IMMEDIATE COMPILE-ONLY +** +** +** At compile-time, a CASE-SYS (see DPANS94 6.2.0873) looks like this: +** i*addr i caseTag +** and an OF-SYS (see DPANS94 6.2.1950) looks like this: +** i*addr i caseTag addr ofTag +** The integer under caseTag is the count of fixup addresses that branch +** to ENDCASE. +**************************************************************************/ + +static void caseCoIm(FICL_VM *pVM) +{ +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 0, 2); +#endif + + PUSHUNS(0); + markControlTag(pVM, caseTag); + return; +} + + +/************************************************************************** + e n d c a s eC o I m +** IMMEDIATE COMPILE-ONLY +**************************************************************************/ + +static void endcaseCoIm(FICL_VM *pVM) +{ + FICL_UNS fixupCount; + FICL_DICT *dp; + CELL *patchAddr; + FICL_INT offset; + + assert(pVM->pSys->pDrop); + + /* + ** if the last OF ended with FALLTHROUGH, + ** just add the FALLTHROUGH fixup to the + ** ENDOF fixups + */ + if (stackGetTop(pVM->pStack).p == fallthroughTag) + { + matchControlTag(pVM, fallthroughTag); + patchAddr = POPPTR(); + matchControlTag(pVM, caseTag); + fixupCount = POPUNS(); + PUSHPTR(patchAddr); + PUSHUNS(fixupCount + 1); + markControlTag(pVM, caseTag); + } + + matchControlTag(pVM, caseTag); + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 0); +#endif + fixupCount = POPUNS(); +#if FICL_ROBUST > 1 + vmCheckStack(pVM, fixupCount, 0); +#endif + + dp = vmGetDict(pVM); + + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDrop)); + + while (fixupCount--) + { + patchAddr = (CELL *)stackPopPtr(pVM->pStack); + offset = dp->here - patchAddr; + *patchAddr = LVALUEtoCELL(offset); + } + return; +} + + +static void ofParen(FICL_VM *pVM) +{ + FICL_UNS a, b; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 2, 1); +#endif + + a = POPUNS(); + b = stackGetTop(pVM->pStack).u; + + if (a == b) + { /* fall through */ + stackDrop(pVM->pStack, 1); + vmBranchRelative(pVM, 1); + } + else + { /* take branch to next of or endswitch */ + vmBranchRelative(pVM, *(int *)(pVM->ip)); + } + + return; +} + + +/************************************************************************** + o f C o I m +** IMMEDIATE COMPILE-ONLY +**************************************************************************/ + +static void ofCoIm(FICL_VM *pVM) +{ + FICL_DICT *dp = vmGetDict(pVM); + CELL *fallthroughFixup = NULL; + + assert(pVM->pSys->pBranch0); + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 1, 3); +#endif + + if (stackGetTop(pVM->pStack).p == fallthroughTag) + { + matchControlTag(pVM, fallthroughTag); + fallthroughFixup = POPPTR(); + } + + matchControlTag(pVM, caseTag); + + markControlTag(pVM, caseTag); + + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pOfParen)); + markBranch(dp, pVM, ofTag); + dictAppendUNS(dp, 2); + + if (fallthroughFixup != NULL) + { + FICL_INT offset = dp->here - fallthroughFixup; + *fallthroughFixup = LVALUEtoCELL(offset); + } + + return; +} + + +/************************************************************************** + e n d o f C o I m +** IMMEDIATE COMPILE-ONLY +**************************************************************************/ + +static void endofCoIm(FICL_VM *pVM) +{ + CELL *patchAddr; + FICL_UNS fixupCount; + FICL_INT offset; + FICL_DICT *dp = vmGetDict(pVM); + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 4, 3); +#endif + + assert(pVM->pSys->pBranchParen); + + /* ensure we're in an OF, */ + matchControlTag(pVM, ofTag); + /* grab the address of the branch location after the OF */ + patchAddr = (CELL *)stackPopPtr(pVM->pStack); + /* ensure we're also in a "case" */ + matchControlTag(pVM, caseTag); + /* grab the current number of ENDOF fixups */ + fixupCount = POPUNS(); + + /* compile branch runtime */ + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); + + /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */ + PUSHPTR(dp->here); + PUSHUNS(fixupCount + 1); + markControlTag(pVM, caseTag); + + /* reserve space for the ENDOF fixup */ + dictAppendUNS(dp, 2); + + /* and patch the original OF */ + offset = dp->here - patchAddr; + *patchAddr = LVALUEtoCELL(offset); +} + + +/************************************************************************** + f a l l t h r o u g h C o I m +** IMMEDIATE COMPILE-ONLY +**************************************************************************/ + +static void fallthroughCoIm(FICL_VM *pVM) +{ + CELL *patchAddr; + FICL_INT offset; + FICL_DICT *dp = vmGetDict(pVM); + +#if FICL_ROBUST > 1 + vmCheckStack(pVM, 4, 3); +#endif + + /* ensure we're in an OF, */ + matchControlTag(pVM, ofTag); + /* grab the address of the branch location after the OF */ + patchAddr = (CELL *)stackPopPtr(pVM->pStack); + /* ensure we're also in a "case" */ + matchControlTag(pVM, caseTag); + + /* okay, here we go. put the case tag back. */ + markControlTag(pVM, caseTag); + + /* compile branch runtime */ + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen)); + + /* push a new FALLTHROUGH fixup and the fallthroughTag */ + PUSHPTR(dp->here); + markControlTag(pVM, fallthroughTag); + + /* reserve space for the FALLTHROUGH fixup */ + dictAppendUNS(dp, 2); + + /* and patch the original OF */ + offset = dp->here - patchAddr; + *patchAddr = LVALUEtoCELL(offset); +} + /************************************************************************** h a s h ** hash ( c-addr u -- code) @@ -2990,9 +3222,9 @@ static void untilCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); - assert(pVM->pSys->pIfParen); + assert(pVM->pSys->pBranch0); - dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); resolveBackBranch(dp, pVM, destTag); return; } @@ -3001,9 +3233,9 @@ static void whileCoIm(FICL_VM *pVM) { FICL_DICT *dp = vmGetDict(pVM); - assert(pVM->pSys->pIfParen); + assert(pVM->pSys->pBranch0); - dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen)); + dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0)); markBranch(dp, pVM, origTag); twoSwap(pVM); dictAppendUNS(dp, 1); @@ -4554,9 +4786,10 @@ WORDKIND ficlWordClassify(FICL_WORD *pFW) {CREATE, createParen}, {DO, doParen}, {DOES, doDoes}, - {IF, ifParen}, + {IF, branch0}, {LITERAL, literalParen}, {LOOP, loopParen}, + {OF, ofParen}, {PLOOP, plusLoopParen}, {QDO, qDoParen}, {CSTRINGLIT, cstringLit}, @@ -4582,6 +4815,28 @@ WORDKIND ficlWordClassify(FICL_WORD *pFW) } +#ifdef TESTMAIN +/************************************************************************** +** r a n d o m +** FICL-specific +**************************************************************************/ +static void ficlRandom(FICL_VM *pVM) +{ + PUSHINT(rand()); +} + + +/************************************************************************** +** s e e d - r a n d o m +** FICL-specific +**************************************************************************/ +static void ficlSeedRandom(FICL_VM *pVM) +{ + srand(POPINT()); +} +#endif + + /************************************************************************** f i c l C o m p i l e C o r e ** Builds the primitive wordset and the environment-query namespace. @@ -4651,6 +4906,7 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "c!", cStore, FW_DEFAULT); dictAppendWord(dp, "c,", cComma, FW_DEFAULT); dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); + dictAppendWord(dp, "case", caseCoIm, FW_COMPIMMED); dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); dictAppendWord(dp, "cells", cells, FW_DEFAULT); dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); @@ -4664,14 +4920,18 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "depth", depth, FW_DEFAULT); dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); + pSys->pDrop = dictAppendWord(dp, "drop", drop, FW_DEFAULT); dictAppendWord(dp, "dup", dup, FW_DEFAULT); dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); dictAppendWord(dp, "emit", emit, FW_DEFAULT); + dictAppendWord(dp, "endcase", endcaseCoIm, FW_COMPIMMED); + dictAppendWord(dp, "endof", endofCoIm, FW_COMPIMMED); dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); dictAppendWord(dp, "execute", execute, FW_DEFAULT); dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); + dictAppendWord(dp, "fallthrough",fallthroughCoIm,FW_COMPIMMED); dictAppendWord(dp, "fill", fill, FW_DEFAULT); dictAppendWord(dp, "find", cFind, FW_DEFAULT); dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); @@ -4693,6 +4953,7 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); dictAppendWord(dp, "move", move, FW_DEFAULT); dictAppendWord(dp, "negate", negate, FW_DEFAULT); + dictAppendWord(dp, "of", ofCoIm, FW_COMPIMMED); dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); dictAppendWord(dp, "over", over, FW_DEFAULT); dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); @@ -4741,7 +5002,6 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE); - /* case of endof endcase */ dictAppendWord(dp, "hex", hex, FW_DEFAULT); dictAppendWord(dp, "pad", pad, FW_DEFAULT); dictAppendWord(dp, "parse", parse, FW_DEFAULT); @@ -4888,6 +5148,10 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); dictAppendWord(dp, "user", userVariable, FW_DEFAULT); #endif +#ifdef TESTMAIN + dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT); + dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT); +#endif /* ** internal support words @@ -4905,8 +5169,8 @@ void ficlCompileCore(FICL_SYSTEM *pSys) dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); pSys->pCStringLit = dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE); - pSys->pIfParen = - dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); + pSys->pBranch0 = + dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE); pSys->pBranchParen = dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); pSys->pDoParen = @@ -4922,6 +5186,8 @@ void ficlCompileCore(FICL_SYSTEM *pSys) pSys->pInterpret = dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); dictAppendWord(dp, "lookup", lookup, FW_DEFAULT); + pSys->pOfParen = + dictAppendWord(dp, "(of)", ofParen, FW_DEFAULT); dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); dictAppendWord(dp, "(parse-step)",