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.
This commit is contained in:
parent
793a8b5fd4
commit
5bf7a61bb3
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/head/; revision=167850
@ -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,
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 -- <method-signature> exc-flag )
|
||||
lookup-method catch
|
||||
;
|
||||
|
@ -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
|
||||
|
@ -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";
|
||||
|
@ -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:
|
||||
|
@ -8,9 +8,9 @@
|
||||
|
||||
|
||||
unsigned long ficlNtohl(unsigned long number)
|
||||
{
|
||||
return ntohl(number);
|
||||
}
|
||||
{
|
||||
return ntohl(number);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
@ -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);
|
||||
|
||||
|
@ -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)",
|
||||
|
Loading…
Reference in New Issue
Block a user