ref: 8950d9094c61f1c559139cd26abb30894a977d67
parent: 2c4ec5704740c223c847a77d09ba5b35fd6dcf95
author: jsadler <jsadler@ficl.sf.net>
date: Sun Nov 4 20:09:29 CST 2001
ficl release 3.01 fileset. Added Files: ficl/fileaccess.c ficl/unix.c ficl/doc/favicon.ico ficl/softwords/fileaccess.fr ficl/softwords/softcore.py ficl/softwords/softcore.py.bat ----------------------------------------------------------------------
--- a/Makefile.riscos
+++ b/Makefile.riscos
@@ -11,9 +11,9 @@
lib: o.libficl
-ficl: testmain.o ficl.h sysdep.h o.libficl
- $(CC) testmain.o -o ficl -L. -lficl -lm
-
+ficl: testmain.o ficl.h sysdep.h o.libficl
+ $(CC) testmain.o -o ficl -L. -lficl -lm
+
# static library build
o.libficl: $(OBJECTS)
$(LIB) o.libficl $(OBJECTS)
--- a/ReadMe.txt
+++ b/ReadMe.txt
@@ -1,3 +1,22 @@
+rel 3.01 -- 2001
+
+Major contribs by Larry Hastings (larry@hastings.org)
+- FILE wordset
+- ficlEvaluate wrapper for ficlExec
+- ficlInitSystemEx makes it possible to bind selectable properties to VMs at create time
+- softcore.py (python version)
+
+Environment contains ficl-version (double)
+?number handles trailing decimal point per DOUBLE wordset spec
+
+Fixed broken .env (thanks to Leonid Rosin for spotting this goof)
+Fixed broken floating point words that depended on evaluation order of stack pops.
+env-constant
+env-2constant
+dictHashSummary is now commented out unless FICL_WANT_FLOAT (thanks to Leonid Rosin again)
+
+Thanks to David McNab for pointing out that .( should be IMMEDIATE. Now it is.
+
rel 3.00a -- July 2001
- Fixed broken oo.fr by commenting out vcall stuff using FICL_WANT_VCALL.
@@ -8,7 +27,7 @@
- Added pSys parameter to most ficlXXXX functions - multiple system support
dictLookupLoc renamed to ficlLookupLoc after addition of pSys param
- ficlInitSystem returns a FICL_SYSTEM*
+ ficlInibtSystem returns a FICL_SYSTEM*
ficlTermSystem
ficlNewVM
ficlLookup
--- a/dict.c
+++ b/dict.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - dictionary methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: dict.c,v 1.11 2001/06/12 08:24:31 jsadler Exp $
+** $Id: dict.c,v 1.12 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** This file implements the dictionary -- FICL's model of
@@ -459,6 +459,7 @@
** addressing scheme (i.e. collisions resolved by searching the
** table for an empty slot) for a given size table.
**************************************************************************/
+#if FICL_WANT_FLOAT
void dictHashSummary(FICL_VM *pVM)
{FICL_DICT *dp = vmGetDict(pVM);
@@ -522,7 +523,7 @@
return;
}
-
+#endif
/**************************************************************************
d i c t I n c l u d e s
binary files /dev/null b/doc/favicon.ico differ
--- a/doc/ficl.html
+++ b/doc/ficl.html
@@ -85,12 +85,10 @@
</LI>
</UL>
<HR>
- <H2>
- <A name="download"></A>Download
- </H2>
+ <h1><A name="links"></A>Links</H1>
<UL>
<LI>
- <B><A href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download ficl (latest release)</A></B>
+ <B><A name="download" href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download ficl (latest release)</A></B>
</LI>
</UL>
<H2>
@@ -111,7 +109,7 @@
</LI>
</UL>
<H2>
- <A name="links"></A>More information on Ficl and Forth
+ More information on Ficl and Forth
</H2>
<UL>
<LI>
binary files a/doc/ficlddj.PDF b/doc/ficlddj.PDF differ
binary files a/doc/jwsforml.PDF b/doc/jwsforml.PDF differ
--- a/ficl.c
+++ b/ficl.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - external interface
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: ficl.c,v 1.13 2001/06/12 08:24:38 jsadler Exp $
+** $Id: ficl.c,v 1.14 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** This is an ANS Forth interpreter written in C.
@@ -75,6 +75,9 @@
static int defaultDict = FICL_DEFAULT_DICT;
+static void ficlSetVersionEnv(FICL_SYSTEM *pSys);
+
+
/**************************************************************************
f i c l I n i t S y s t e m
** Binds a global dictionary to the interpreter system.
@@ -86,8 +89,9 @@
** precompiled part. Try 1K cells minimum. Use "words" to find
** out how much of the dictionary is used at any time.
**************************************************************************/
-FICL_SYSTEM *ficlInitSystem(int nDictCells)
+FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi)
{+ int nDictCells = fsi->nDictCells;
FICL_SYSTEM *pSys = ficlMalloc(sizeof (FICL_SYSTEM));
assert(pSys);
@@ -102,6 +106,9 @@
pSys->envp = dictCreate((unsigned)FICL_DEFAULT_ENV);
pSys->envp->pForthWords->name = "environment";
+ pSys->textOut = fsi->textOut;
+ pSys->context = fsi->context;
+
#if FICL_WANT_LOCALS
/*
** The locals dictionary is only searched while compiling,
@@ -114,28 +121,32 @@
#endif
/*
- ** Establish the parse order. Note that prefixes precede numbers -
- ** this allows constructs like "0b101010" which might parse as a
- ** hex value otherwise.
- */
- ficlCompilePrefix(pSys);
- ficlAddPrecompiledParseStep(pSys, "?number", ficlParseNumber);
-
- /*
** Build the precompiled dictionary and load softwords. We need a temporary
** VM to do this - ficlNewVM links one to the head of the system VM list.
** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words.
*/
ficlCompileCore(pSys);
+ ficlCompilePrefix(pSys);
#if FICL_WANT_FLOAT
ficlCompileFloat(pSys);
#endif
-
#if FICL_PLATFORM_EXTEND
ficlCompilePlatform(pSys);
#endif
+ ficlSetVersionEnv(pSys);
/*
+ ** Establish the parse order. Note that prefixes precede numbers -
+ ** this allows constructs like "0b101010" which might parse as a
+ ** hex value otherwise.
+ */
+ ficlAddPrecompiledParseStep(pSys, "?prefix", ficlParsePrefix);
+ ficlAddPrecompiledParseStep(pSys, "?number", ficlParseNumber);
+#if FICL_WANT_FLOAT
+ ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber);
+#endif
+
+ /*
** Now create a temporary VM to compile the softwords. Since all VMs are
** linked into the vmList of FICL_SYSTEM, we don't have to pass the VM
** to ficlCompileSoftCore -- it just hijacks whatever it finds in the VM list.
@@ -152,6 +163,15 @@
}
+FICL_SYSTEM *ficlInitSystem(int nDictCells)
+{+ FICL_SYSTEM_INFO fsi;
+ ficlInitInfo(&fsi);
+ fsi.nDictCells = nDictCells;
+ return ficlInitSystemEx(&fsi);
+}
+
+
/**************************************************************************
f i c l A d d P a r s e S t e p
** Appends a parse step function to the end of the parse list (see
@@ -223,6 +243,7 @@
FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
pVM->link = pSys->vmList;
pVM->pSys = pSys;
+ vmSetTextOut(pVM, pSys->textOut);
pSys->vmList = pVM;
return pVM;
@@ -279,8 +300,10 @@
**************************************************************************/
int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags)
{+#if FICL_MULTITHREAD
int err = ficlLockDictionary(TRUE);
if (err) return err;
+#endif /* FICL_MULTITHREAD */
assert(dictCellsAvail(pSys->dp) > sizeof (FICL_WORD) / sizeof (CELL));
dictAppendWord(pSys->dp, name, code, flags);
@@ -291,6 +314,21 @@
/**************************************************************************
+ f i c l E v a l u a t e
+** Wrapper for ficlExec() which sets SOURCE-ID to -1.
+*/
+int ficlEvaluate(FICL_VM *pVM, char *pText)
+{+ int returnValue;
+ CELL id = pVM->sourceID;
+ pVM->sourceID.i = -1;
+ returnValue = ficlExecC(pVM, pText, -1);
+ pVM->sourceID = id;
+ return returnValue;
+}
+
+
+/**************************************************************************
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
@@ -316,8 +354,7 @@
int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
{FICL_SYSTEM *pSys = pVM->pSys;
- FICL_WORD **pInterp = pSys->pInterp;
- FICL_DICT *dp = pSys->dp;
+ FICL_DICT *dp = pSys->dp;
int except;
jmp_buf vmState;
@@ -324,15 +361,8 @@
jmp_buf *oldState;
TIB saveTib;
- if (!pInterp[0])
- {- pInterp[0] = ficlLookup(pSys, "interpret");
- pInterp[1] = ficlLookup(pSys, "(branch)");
- pInterp[2] = (FICL_WORD *)(void *)(-2);
- }
-
- assert(pInterp[0]);
assert(pVM);
+ assert(pSys->pInterp[0]);
if (size < 0)
size = strlen(pText);
@@ -356,7 +386,7 @@
}
else
{ /* set VM up to interpret text */- vmPushIP(pVM, &pInterp[0]);
+ vmPushIP(pVM, &(pSys->pInterp[0]));
}
vmInnerLoop(pVM);
@@ -430,17 +460,13 @@
**************************************************************************/
int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
{- static FICL_WORD *pQuit = NULL;
int except;
jmp_buf vmState;
jmp_buf *oldState;
FICL_WORD *oldRunningWord;
- if (!pQuit)
- pQuit = ficlLookup(pVM->pSys, "exit-inner");
-
assert(pVM);
- assert(pQuit);
+ assert(pVM->pSys->pExitInner);
/*
** Save the runningword so that RESTART behaves correctly
@@ -457,7 +483,7 @@
if (except)
vmPopIP(pVM);
else
- vmPushIP(pVM, &pQuit);
+ vmPushIP(pVM, &(pVM->pSys->pExitInner));
switch (except)
{@@ -640,4 +666,17 @@
return;
}
+
+/**************************************************************************
+ f i c l S e t V e r s i o n E n v
+** Create a double cell environment constant for the version ID
+**************************************************************************/
+static void ficlSetVersionEnv(FICL_SYSTEM *pSys)
+{+ int major = 0;
+ int minor = 0;
+ sscanf(FICL_VER, "%d.%d", &major, &minor);
+ ficlSetEnvD(pSys, "ficl-version", major, minor);
+ return;
+}
--- a/ficl.dsp
+++ b/ficl.dsp
@@ -96,6 +96,10 @@
# End Source File
# Begin Source File
+SOURCE=.\fileaccess.c
+# End Source File
+# Begin Source File
+
SOURCE=.\float.c
# End Source File
# Begin Source File
@@ -185,6 +189,10 @@
# End Source File
# Begin Source File
+SOURCE=.\softwords\fileaccess.fr
+# End Source File
+# Begin Source File
+
SOURCE=.\softwords\forml.fr
# End Source File
# Begin Source File
@@ -234,6 +242,10 @@
# Begin Source File
SOURCE=.\doc\ficl_debug.html
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficl_guts.htm
# End Source File
# Begin Source File
--- a/ficl.h
+++ b/ficl.h
@@ -4,7 +4,7 @@
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** Dedicated to RHS, in loving memory
-** $Id: ficl.h,v 1.15 2001/06/12 08:24:33 jsadler Exp $
+** $Id: ficl.h,v 1.16 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -220,6 +220,7 @@
#include "sysdep.h"
#include <limits.h> /* UCHAR_MAX */
+#include <stdio.h>
/*
** Forward declarations... read on.
@@ -232,11 +233,13 @@
typedef struct ficl_dict FICL_DICT;
struct ficl_system;
typedef struct ficl_system FICL_SYSTEM;
+struct ficl_system_info;
+typedef struct ficl_system_info FICL_SYSTEM_INFO;
/*
** the Good Stuff starts here...
*/
-#define FICL_VER "3.00"
+#define FICL_VER "3.01"
#if !defined (FICL_PROMPT)
#define FICL_PROMPT "ok> "
#endif
@@ -471,6 +474,7 @@
struct vm
{FICL_SYSTEM *pSys; /* Which system this VM belongs to */
+ void *context; /* Not used by FICL--use this for your own data */
FICL_VM *link; /* Ficl keeps a VM list for simple teardown */
jmp_buf *pState; /* crude exception mechanism... */
OUTFUNC textOut; /* Output callback - see sysdep.c */
@@ -485,7 +489,7 @@
#if FICL_WANT_FLOAT
FICL_STACK *fStack; /* float stack (optional) */
#endif
- CELL sourceID; /* -1 if string, 0 if normal input */
+ CELL sourceID; /* -1 if EVALUATE, 0 if normal input */
TIB tib; /* address of incoming text string */
#if FICL_WANT_USER
CELL user[FICL_USER_CELLS];
@@ -582,10 +586,8 @@
void vmQuit (FICL_VM *pVM);
void vmReset (FICL_VM *pVM);
void vmSetTextOut (FICL_VM *pVM, OUTFUNC textOut);
-#if FICL_WANT_DEBUGGER
-void vmStep (FICL_VM *pVM);
-#endif
void vmTextOut (FICL_VM *pVM, char *text, int fNewline);
+void vmTextOut (FICL_VM *pVM, char *text, int fNewline);
void vmThrow (FICL_VM *pVM, int except);
void vmThrowErr (FICL_VM *pVM, char *fmt, ...);
@@ -759,7 +761,9 @@
FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets);
void dictDelete (FICL_DICT *pDict);
void dictEmpty (FICL_DICT *pDict, unsigned nHash);
+#if FICL_WANT_FLOAT
void dictHashSummary(FICL_VM *pVM);
+#endif
int dictIncludes (FICL_DICT *pDict, void *p);
FICL_WORD *dictLookup (FICL_DICT *pDict, STRINGINFO si);
#if FICL_WANT_LOCALS
@@ -806,6 +810,23 @@
void ficlListParseSteps(FICL_VM *pVM);
/*
+** FICL_BREAKPOINT record.
+** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
+** that the breakpoint overwrote. This is restored to the dictionary when the
+** BP executes or gets cleared
+** address - the location of the breakpoint (address of the instruction that
+** has been replaced with the breakpoint trap
+** origXT - The original contents of the location with the breakpoint
+** Note: address is NULL when this breakpoint is empty
+*/
+typedef struct FICL_BREAKPOINT
+{+ void *address;
+ FICL_WORD *origXT;
+} FICL_BREAKPOINT;
+
+
+/*
** F I C L _ S Y S T E M
** The top level data structure of the system - ficl_system ties a list of
** virtual machines with their corresponding dictionaries. Ficl 3.0 will
@@ -813,16 +834,11 @@
** to separate dictionaries with some constraints.
** The present model allows multiple sessions to one dictionary provided
** you implement ficlLockDictionary() as specified in sysdep.h
-**
-** RESTRICTIONS: due to the use of static variables in words.c for compiling
-** comtrol structures faster, if you use multiple ficl systems these variables
-** will point into the most recently initialized dictionary - this is probably
-** not a problem provided the precompiled dictionaries are identical for
-** all systems.
*/
struct ficl_system
{FICL_SYSTEM *link;
+ void *context; /* Not used by FICL--use this for your own data */
FICL_VM *vmList;
FICL_DICT *dp;
FICL_DICT *envp;
@@ -831,8 +847,55 @@
#endif
FICL_WORD *pInterp[3];
FICL_WORD *parseList[FICL_MAX_PARSE_STEPS];
+ OUTFUNC textOut;
+
+ FICL_WORD *pBranchParen;
+ FICL_WORD *pDoParen;
+ FICL_WORD *pDoesParen;
+ FICL_WORD *pExitInner;
+ FICL_WORD *pExitParen;
+ FICL_WORD *pIfParen;
+ FICL_WORD *pInterpret;
+ FICL_WORD *pLitParen;
+ FICL_WORD *pTwoLitParen;
+ FICL_WORD *pLoopParen;
+ FICL_WORD *pPLoopParen;
+ FICL_WORD *pQDoParen;
+ FICL_WORD *pSemiParen;
+ FICL_WORD *pStore;
+ FICL_WORD *pCStringLit;
+ FICL_WORD *pStringLit;
+
+#if FICL_WANT_LOCALS
+ FICL_WORD *pGetLocalParen;
+ FICL_WORD *pGet2LocalParen;
+ FICL_WORD *pGetLocal0;
+ FICL_WORD *pGetLocal1;
+ FICL_WORD *pToLocalParen;
+ FICL_WORD *pTo2LocalParen;
+ FICL_WORD *pToLocal0;
+ FICL_WORD *pToLocal1;
+ FICL_WORD *pLinkParen;
+ FICL_WORD *pUnLinkParen;
+ FICL_INT nLocals;
+ CELL *pMarkLocals;
+#endif
+
+ FICL_BREAKPOINT bpStep;
};
+struct ficl_system_info
+{+ int size;
+ int nDictCells;
+ OUTFUNC textOut;
+ void *context;
+};
+
+
+#define ficlInitInfo(x) { memset((x), 0, sizeof(FICL_SYSTEM_INFO)); \+ (x)->size = sizeof(FICL_SYSTEM_INFO); }
+
/*
** External interface to FICL...
*/
@@ -840,7 +903,8 @@
** f i c l I n i t S y s t e m
** Binds a global dictionary to the interpreter system and initializes
** the dict to contain the ANSI CORE wordset.
-** You specify the address and size of the allocated area.
+** You can specify the address and size of the allocated area.
+** Using ficlInitSystemEx you can also specify the text output function.
** After that, ficl manages it.
** First step is to set up the static pointers to the area.
** Then write the "precompiled" portion of the dictionary in.
@@ -848,6 +912,9 @@
** precompiled part. Try 1K cells minimum. Use "words" to find
** out how much of the dictionary is used at any time.
*/
+FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi);
+
+/* Deprecated call */
FICL_SYSTEM *ficlInitSystem(int nDictCells);
/*
@@ -859,6 +926,16 @@
void ficlTermSystem(FICL_SYSTEM *pSys);
/*
+** f i c l E v a l u a t e
+** Evaluates a block of input text in the context of the
+** specified interpreter. Also sets SOURCE-ID properly.
+**
+** PLEASE USE THIS FUNCTION when throwing a hard-coded
+** string to the FICL interpreter.
+*/
+int ficlEvaluate(FICL_VM *pVM, char *pText);
+
+/*
** 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
@@ -879,6 +956,10 @@
** commands.
** Preconditions: successful execution of ficlInitSystem,
** Successful creation and init of the VM by ficlNewVM (or equiv)
+**
+** If you call ficlExec() or one of its brothers, you MUST
+** ensure pVM->sourceID was set to a sensible value.
+** ficlExec() explicitly DOES NOT manage SOURCE-ID for you.
*/
int ficlExec (FICL_VM *pVM, char *pText);
int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT nChars);
@@ -955,12 +1036,15 @@
void ficlCompileSearch(FICL_SYSTEM *pSys);
void ficlCompileSoftCore(FICL_SYSTEM *pSys);
void ficlCompileTools(FICL_SYSTEM *pSys);
+void ficlCompileFile(FICL_SYSTEM *pSys);
#if FICL_WANT_FLOAT
void ficlCompileFloat(FICL_SYSTEM *pSys);
+int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ); /* float.c */
#endif
#if FICL_PLATFORM_EXTEND
void ficlCompilePlatform(FICL_SYSTEM *pSys);
#endif
+int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si);
/*
** from words.c...
@@ -994,11 +1078,33 @@
PRIMITIVE,
QDO,
STRINGLIT,
+ CSTRINGLIT,
+#if FICL_WANT_USER
USER,
+#endif
VARIABLE,
} WORDKIND;
WORDKIND ficlWordClassify(FICL_WORD *pFW);
+
+
+
+/*
+** Used with File-Access wordset.
+*/
+#define FICL_FAM_READ 1
+#define FICL_FAM_WRITE 2
+#define FICL_FAM_APPEND 4
+#define FICL_FAM_BINARY 8
+
+#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND))
+
+
+typedef struct ficlFILE
+{+ FILE *f;
+ char filename[256];
+} ficlFILE;
#ifdef __cplusplus
}
--- /dev/null
+++ b/fileaccess.c
@@ -1,0 +1,423 @@
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <sys/stat.h>
+#include "ficl.h"
+
+#if FICL_WANT_FILE
+/*
+**
+** fileaccess.c
+**
+** Implements all of the File Access word set that can be implemented in portable C.
+**
+*/
+
+static void pushIor(FICL_VM *pVM, int success)
+{+ int ior;
+ if (success)
+ ior = 0;
+ else
+ ior = errno;
+ stackPushINT(pVM->pStack, ior);
+}
+
+
+
+static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
+{+ int fam = stackPopINT(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+ char mode[4];
+ FILE *f;
+
+ char *filename = (char *)_alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ *mode = 0;
+
+ switch (FICL_FAM_OPEN_MODE(fam))
+ {+ case 0:
+ stackPushPtr(pVM->pStack, NULL);
+ stackPushINT(pVM->pStack, EINVAL);
+ return;
+ case FICL_FAM_READ:
+ strcat(mode, "r");
+ break;
+ case FICL_FAM_WRITE:
+ strcat(mode, writeMode);
+ break;
+ case FICL_FAM_READ | FICL_FAM_WRITE:
+ strcat(mode, writeMode);
+ strcat(mode, "+");
+ break;
+ }
+
+ strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");
+
+ f = fopen(filename, mode);
+ if (f == NULL)
+ stackPushPtr(pVM->pStack, NULL);
+ else
+ {+ ficlFILE *ff = (ficlFILE *)malloc(sizeof(ficlFILE));
+ strcpy(ff->filename, filename);
+ ff->f = f;
+ stackPushPtr(pVM->pStack, ff);
+
+ fseek(f, 0, SEEK_SET);
+ }
+ pushIor(pVM, f != NULL);
+}
+
+
+
+static void ficlOpenFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+{+ ficlFopen(pVM, "a");
+}
+
+
+static void ficlCreateFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+{+ ficlFopen(pVM, "w");
+}
+
+
+static int closeFiclFILE(ficlFILE *ff) /* ( fileid -- ior ) */
+{+ FILE *f = ff->f;
+ free(ff);
+ return !fclose(f);
+}
+
+static void ficlCloseFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ pushIor(pVM, closeFiclFILE(ff));
+}
+
+static void ficlDeleteFile(FICL_VM *pVM) /* ( c-addr u -- ior ) */
+{+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *filename = (char *)_alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ pushIor(pVM, !unlink(filename));
+}
+
+static void ficlRenameFile(FICL_VM *pVM) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
+{+ int length;
+ void *address;
+ char *from;
+ char *to;
+
+ length = stackPopINT(pVM->pStack);
+ address = (void *)stackPopPtr(pVM->pStack);
+ to = (char *)_alloca(length + 1);
+ memcpy(to, address, length);
+ to[length] = 0;
+
+ length = stackPopINT(pVM->pStack);
+ address = (void *)stackPopPtr(pVM->pStack);
+
+ from = (char *)_alloca(length + 1);
+ memcpy(from, address, length);
+ from[length] = 0;
+
+ pushIor(pVM, !rename(from, to));
+}
+
+static void ficlFileStatus(FICL_VM *pVM) /* ( c-addr u -- x ior ) */
+{+ struct stat statbuf;
+
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *filename = (char *)_alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ if (stat(filename, &statbuf) == 0)
+ {+ /*
+ ** the "x" left on the stack is implementation-defined.
+ ** I push the file's access mode (readable, writeable, is directory, etc)
+ ** as defined by ANSI C.
+ */
+ stackPushINT(pVM->pStack, statbuf.st_mode);
+ stackPushINT(pVM->pStack, 0);
+ }
+ else
+ {+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, ENOENT);
+ }
+}
+
+
+static void ficlFilePosition(FICL_VM *pVM) /* ( fileid -- ud ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ long ud = ftell(ff->f);
+ stackPushINT(pVM->pStack, ud);
+ pushIor(pVM, ud != -1);
+}
+
+
+
+static long fileSize(FILE *f)
+{+ struct _stat statbuf;
+ statbuf.st_size = -1;
+ if (_fstat(fileno(f), &statbuf) != 0)
+ return -1;
+ return statbuf.st_size;
+}
+
+
+
+static void ficlFileSize(FICL_VM *pVM) /* ( fileid -- ud ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ long ud = fileSize(ff->f);
+ stackPushINT(pVM->pStack, ud);
+ pushIor(pVM, ud != -1);
+}
+
+
+
+#define nLINEBUF 256
+static void ficlIncludeFile(FICL_VM *pVM) /* ( i*x fileid -- j*x ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ CELL id = pVM->sourceID;
+ int result = VM_OUTOFTEXT;
+ long currentPosition, totalSize;
+ long size;
+ pVM->sourceID.p = (void *)ff;
+
+ currentPosition = ftell(ff->f);
+ totalSize = fileSize(ff->f);
+ size = totalSize - currentPosition;
+
+ if ((totalSize != -1) && (currentPosition != -1) && (size > 0))
+ {+ char *buffer = (char *)malloc(size);
+ long got = fread(buffer, 1, size, ff->f);
+ if (got == size)
+ result = ficlExecC(pVM, buffer, size);
+ }
+
+#if 0
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ CELL id = pVM->sourceID;
+ char cp[nLINEBUF];
+ int nLine = 0;
+ int keepGoing;
+ int result;
+ pVM->sourceID.p = (void *)ff;
+
+ /* feed each line to ficlExec */
+ keepGoing = TRUE;
+ while (keepGoing && fgets(cp, nLINEBUF, ff->f))
+ {+ int len = strlen(cp) - 1;
+
+ nLine++;
+ if (len <= 0)
+ continue;
+
+ if (cp[len] == '\n')
+ cp[len] = '\0';
+
+ result = ficlExec(pVM, cp);
+
+ switch (result)
+ {+ case VM_OUTOFTEXT:
+ case VM_USEREXIT:
+ break;
+
+ default:
+ pVM->sourceID = id;
+ keepGoing = FALSE;
+ break;
+ }
+ }
+#endif /* 0 */
+ /*
+ ** Pass an empty line with SOURCE-ID == -1 to flush
+ ** any pending REFILLs (as required by FILE wordset)
+ */
+ pVM->sourceID.i = -1;
+ ficlExec(pVM, "");
+
+ pVM->sourceID = id;
+ closeFiclFILE(ff);
+}
+
+
+
+static void ficlReadFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+ int result;
+
+ clearerr(ff->f);
+ result = fread(address, 1, length, ff->f);
+
+ stackPushINT(pVM->pStack, result);
+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ char *address = (char *)stackPopPtr(pVM->pStack);
+ int error;
+ int flag;
+
+ if (feof(ff->f))
+ {+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, 0);
+ stackPushINT(pVM->pStack, 0);
+ return;
+ }
+
+ clearerr(ff->f);
+ *address = 0;
+ fgets(address, length, ff->f);
+
+ error = ferror(ff->f);
+ if (error != 0)
+ {+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, 0);
+ stackPushINT(pVM->pStack, error);
+ return;
+ }
+
+ length = strlen(address);
+ flag = (length > 0);
+ if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
+ length--;
+
+ stackPushINT(pVM->pStack, length);
+ stackPushINT(pVM->pStack, flag);
+ stackPushINT(pVM->pStack, 0); /* ior */
+}
+
+
+
+static void ficlWriteFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ clearerr(ff->f);
+ fwrite(address, 1, length, ff->f);
+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlWriteLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t length = (size_t)stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ clearerr(ff->f);
+ if (fwrite(address, 1, length, ff->f) == length)
+ fwrite("\n", 1, 1, ff->f);+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlRepositionFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t ud = (size_t)stackPopINT(pVM->pStack);
+
+ pushIor(pVM, fseek(ff->f, ud, SEEK_SET) == 0);
+}
+
+
+
+static void ficlFlushFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ pushIor(pVM, fflush(ff->f) == 0);
+}
+
+
+
+#if FICL_HAVE_FTRUNCATE
+
+static void ficlResizeFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+{+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t ud = (size_t)stackPopINT(pVM->pStack);
+
+ pushIor(pVM, ftruncate(fileno(ff->f), ud) == 0);
+}
+
+#endif /* FICL_HAVE_FTRUNCATE */
+
+#endif /* FICL_WANT_FILE */
+
+
+
+void ficlCompileFile(FICL_SYSTEM *pSys)
+{+#if FICL_WANT_FILE
+ FICL_DICT *dp = pSys->dp;
+ assert(dp);
+
+ dictAppendWord(dp, "create-file", ficlCreateFile, FW_DEFAULT);
+ dictAppendWord(dp, "open-file", ficlOpenFile, FW_DEFAULT);
+ dictAppendWord(dp, "close-file", ficlCloseFile, FW_DEFAULT);
+ dictAppendWord(dp, "include-file", ficlIncludeFile, FW_DEFAULT);
+ dictAppendWord(dp, "read-file", ficlReadFile, FW_DEFAULT);
+ dictAppendWord(dp, "read-line", ficlReadLine, FW_DEFAULT);
+ dictAppendWord(dp, "write-file", ficlWriteFile, FW_DEFAULT);
+ dictAppendWord(dp, "write-line", ficlWriteLine, FW_DEFAULT);
+ dictAppendWord(dp, "file-position", ficlFilePosition, FW_DEFAULT);
+ dictAppendWord(dp, "file-size", ficlFileSize, FW_DEFAULT);
+ dictAppendWord(dp, "reposition-file", ficlRepositionFile, FW_DEFAULT);
+ dictAppendWord(dp, "file-status", ficlFileStatus, FW_DEFAULT);
+ dictAppendWord(dp, "flush-file", ficlFlushFile, FW_DEFAULT);
+
+ dictAppendWord(dp, "delete-file", ficlDeleteFile, FW_DEFAULT);
+ dictAppendWord(dp, "rename-file", ficlRenameFile, FW_DEFAULT);
+
+#ifdef FICL_HAVE_FTRUNCATE
+ dictAppendWord(dp, "resize-file", ficlResizeFile, FW_DEFAULT);
+
+ ficlSetEnv(pSys, "file", FICL_TRUE);
+ ficlSetEnv(pSys, "file-ext", FICL_TRUE);
+#endif /* FICL_HAVE_FTRUNCATE */
+#else
+ &pSys;
+#endif /* FICL_WANT_FILE */
+}
--- a/float.c
+++ b/float.c
@@ -4,7 +4,7 @@
** ANS Forth FLOAT word-set written in C
** Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu)
** Created: Apr 2001
-** $Id: float.c,v 1.5 2001/07/24 05:01:24 jsadler Exp $
+** $Id: float.c,v 1.6 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -62,7 +62,8 @@
vmCheckFStack(pVM, 2, 1);
#endif
- f = POPFLOAT() + GETTOPF().f;
+ f = POPFLOAT();
+ f += GETTOPF().f;
SETTOPF(f);
}
@@ -95,7 +96,8 @@
vmCheckFStack(pVM, 2, 1);
#endif
- f = POPFLOAT() * GETTOPF().f;
+ f = POPFLOAT();
+ f *= GETTOPF().f;
SETTOPF(f);
}
@@ -145,7 +147,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = (FICL_FLOAT)POPINT() + GETTOPF().f;
+ f = (FICL_FLOAT)POPINT();
+ f += GETTOPF().f;
SETTOPF(f);
}
@@ -162,7 +165,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = GETTOPF().f - (FICL_FLOAT)POPINT();
+ f = GETTOPF().f;
+ f -= (FICL_FLOAT)POPINT();
SETTOPF(f);
}
@@ -179,7 +183,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = (FICL_FLOAT)POPINT() * GETTOPF().f;
+ f = (FICL_FLOAT)POPINT();
+ f *= GETTOPF().f;
SETTOPF(f);
}
@@ -196,7 +201,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = GETTOPF().f / (FICL_FLOAT)POPINT();
+ f = GETTOPF().f;
+ f /= (FICL_FLOAT)POPINT();
SETTOPF(f);
}
@@ -213,7 +219,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = (FICL_FLOAT)POPINT() - GETTOPF().f;
+ f = (FICL_FLOAT)POPINT();
+ f -= GETTOPF().f;
SETTOPF(f);
}
@@ -230,7 +237,8 @@
vmCheckStack(pVM, 1, 0);
#endif
- f = (FICL_FLOAT)POPINT() / GETTOPF().f;
+ f = (FICL_FLOAT)POPINT();
+ f /= GETTOPF().f;
SETTOPF(f);
}
@@ -1034,8 +1042,6 @@
ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */
ficlSetEnv(pSys, "floating-ext", FICL_FALSE);
ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK);
-
- ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber);
#endif
return;
}
\ No newline at end of file
--- a/math64.c
+++ b/math64.c
@@ -5,7 +5,7 @@
** Created: 25 January 1998
** Rev 2.03: Support for 128 bit DP math. This file really ouught to
** be renamed!
-** $Id: math64.c,v 1.6 2001/05/16 14:56:16 jsadler Exp $
+** $Id: math64.c,v 1.7 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
--- a/math64.h
+++ b/math64.h
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - 64 bit math support routines
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 25 January 1998
-** $Id: math64.h,v 1.6 2001/05/16 14:56:19 jsadler Exp $
+** $Id: math64.h,v 1.7 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
--- a/prefix.c
+++ b/prefix.c
@@ -4,7 +4,7 @@
** Parser extensions for Ficl
** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu)
** Created: April 2001
-** $Id: prefix.c,v 1.3 2001/06/12 08:24:38 jsadler Exp $
+** $Id: prefix.c,v 1.4 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -179,7 +179,7 @@
dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT);
dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT);
#if (FICL_EXTENDED_PREFIX)
- pFW = ficlLookup("\\");+ pFW = ficlLookup(pSys, "\\");
if (pFW)
{dictAppendWord(dp, "//", pFW->code, FW_DEFAULT);
@@ -187,6 +187,5 @@
#endif
dp->pCompile = pPrevCompile;
- ficlAddPrecompiledParseStep(pSys, "?prefix", ficlParsePrefix);
return;
}
--- a/search.c
+++ b/search.c
@@ -4,7 +4,7 @@
** ANS Forth SEARCH and SEARCH-EXT word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 6 June 2000
-** $Id: search.c,v 1.6 2001/06/12 08:24:34 jsadler Exp $
+** $Id: search.c,v 1.7 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
--- a/softcore.c
+++ b/softcore.c
@@ -4,7 +4,7 @@
** Words from CORE set written in FICL
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 27 December 1997
-** Last update: Sat Jul 21 17:31:36 2001
+** Last update: Sat Aug 4 16:47:07 2001
*******************************************************************/
/*
** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
@@ -188,6 +188,27 @@
"; "
": debug ' debug-xt ; "
": on-step .\" S: \" .s cr ; "
+ ": strdup "
+ "0 locals| addr2 length c-addr | end-locals "
+ "length 1 + allocate "
+ "0= if "
+ "to addr2 "
+ "c-addr addr2 length move "
+ "addr2 length 0 "
+ "else "
+ "0 -1 "
+ "endif "
+ "; "
+ ": strcat "
+ "0 locals| b-length b-u b-addr a-u a-addr | end-locals "
+ "b-u to b-length "
+ "b-addr a-addr a-u + b-length move "
+ "a-addr a-u b-length + "
+ "; "
+ ": strcpy "
+ "locals| b-u b-addr a-u a-addr | end-locals "
+ "a-addr 0 b-addr b-u strcat "
+ "; "
"previous "
/*
** E N D S O F T C O R E . F R
@@ -317,21 +338,14 @@
*/
"hide "
": ?[if] "
- "2dup 2dup "
- "s\" [if]\" compare 0= >r "
- "s\" [IF]\" compare 0= r> "
- "or "
+ "2dup s\" [if]\" compare-insensitive 0= "
"; "
": ?[else] "
- "2dup 2dup "
- "s\" [else]\" compare 0= >r "
- "s\" [ELSE]\" compare 0= r> "
- "or "
+ "2dup s\" [else]\" compare-insensitive 0= "
"; "
": ?[then] "
- "2dup 2dup "
- "s\" [then]\" compare 0= >r "
- "s\" [THEN]\" compare 0= r> "
+ "2dup s\" [then]\" compare-insensitive 0= >r "
+ "2dup s\" [endif]\" compare-insensitive 0= r> "
"or "
"; "
"set-current "
@@ -356,6 +370,7 @@
": [if] "
"0= if postpone [else] then ; immediate "
": [then] ; immediate "
+ ": [endif] ; immediate "
"previous "
#if FICL_WANT_OOP
/*
@@ -961,6 +976,28 @@
"end-class "
"previous definitions "
#endif
+#if FICL_WANT_FILE
+/*
+**
+** File Access words for ficl
+** submitted by Larry Hastings, larry@hastings.org
+**
+*/
+ ": r/o 1 ; "
+ ": r/w 3 ; "
+ ": w/o 2 ; "
+ ": bin 8 or ; "
+ ": included "
+ "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 "
+#endif
#endif /* WANT_SOFTWORDS */
"quit ";
@@ -968,10 +1005,12 @@
void ficlCompileSoftCore(FICL_SYSTEM *pSys)
{FICL_VM *pVM = pSys->vmList;
+ CELL id = pVM->sourceID;
int ret = sizeof (softWords);
- assert(pVM);
-
+ assert(pVM);
+ pVM->sourceID.i = -1;
ret = ficlExec(pVM, softWords);
+ pVM->sourceID = id;
if (ret == VM_ERREXIT)
assert(FALSE);
return;
--- /dev/null
+++ b/softwords/fileaccess.fr
@@ -1,0 +1,24 @@
+\ #if FICL_WANT_FILE
+\ **
+\ ** File Access words for ficl
+\ ** submitted by Larry Hastings, larry@hastings.org
+\ **
+
+: r/o 1 ;
+: r/w 3 ;
+: w/o 2 ;
+: bin 8 or ;
+
+: included
+ 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
+
+\ #endif
--- a/softwords/ifbrack.fr
+++ b/softwords/ifbrack.fr
@@ -5,23 +5,16 @@
hide
: ?[if] ( c-addr u -- c-addr u flag )
- 2dup 2dup
- s" [if]" compare 0= >r
- s" [IF]" compare 0= r>
- or
+ 2dup s" [if]" compare-insensitive 0=
;
: ?[else] ( c-addr u -- c-addr u flag )
- 2dup 2dup
- s" [else]" compare 0= >r
- s" [ELSE]" compare 0= r>
- or
+ 2dup s" [else]" compare-insensitive 0=
;
: ?[then] ( c-addr u -- c-addr u flag )
- 2dup 2dup
- s" [then]" compare 0= >r
- s" [THEN]" compare 0= r>
+ 2dup s" [then]" compare-insensitive 0= >r
+ 2dup s" [endif]" compare-insensitive 0= r>
or
;
@@ -50,5 +43,6 @@
0= if postpone [else] then ; immediate
: [then] ( -- ) ; immediate
+: [endif] ( -- ) ; immediate
previous
--- a/softwords/makefile
+++ b/softwords/makefile
@@ -1,4 +1,4 @@
-SOURCES = softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr
+SOURCES = softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr
softcore.c: softcore.pl $(SOURCES)
./softcore.pl $(SOURCES) >softcore.c
--- a/softwords/oo.fr
+++ b/softwords/oo.fr
@@ -29,8 +29,7 @@
\ A ficl object binds instance storage (payload) to a class.
\ object ( -- instance class )
\ All objects push their payload address and class address when
-\ executed. All objects have this footprint:
-\ cell 0: first payload cell
+\ executed.
\ A ficl class consists of a parent class pointer, a wordlist
\ ID for the methods of the class, and a size for the payload
@@ -42,14 +41,39 @@
\ cell 2: size of instance's payload
\ Methods expect an object couple ( instance class )
-\ on the stack.
+\ on the stack. This is by convention - ficl has no way to
+\ police your code to make sure this is always done, but it
+\ happens naturally if you use the facilities presented here.
+\
\ Overridden methods must maintain the same stack signature as
-\ their predecessors. Ficl has no way of enforcing this, though.
+\ their predecessors. Ficl has no way of enforcing this, either.
\
\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
\ has an extra field for the vtable method count. Hasvtable declares
\ refs to vtable classes
+\
+\ Revised August 2001 - Ficl vtable support
+\ Each class has a vtable size parameter
+\ END-CLASS allocates and clears the vtable - then it walks class's method
+\ list and inserts all new methods into table. For each method, if the table
+\ slot is already nonzero, do nothing (overridden method). Otherwise fill
+\ vtable slot. Now do same check for parent class vtable, filling only
+\ empty slots in the new vtable.
+\ Methods are now structured as follows:
+\ - header
+\ - vtable index
+\ - xt
+\ :noname definition for code
+\
+\ : is redefined to check for override, fill in vtable index, increment method
+\ count if not an override, create header and fill in index. Allot code pointer
+\ and run :noname
+\ ; is overridden to fill in xt returned by :noname
+\ --> compiles code to fetch vtable address, offset by index, and execute
+\ => looks up xt in the vtable and compiles it directly
+
+
user current-class
0 current-class !
@@ -57,17 +81,25 @@
\ ** L A T E B I N D I N G
\ Compile the method name, and code to find and
\ execute it at run-time...
-\ parse-method compiles the method name so that it pushes
-\ the string base address and count 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.
+
: parse-method \ name run: ( -- c-addr u )
parse-word
postpone sliteral
; compile-only
+\ 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
+\ the class that's on the stack. If successful, it leaves the class on the stack
+\ 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 )
@@ -116,6 +148,11 @@
\ METHOD makes global words that do method invocations by late binding
\ in case you prefer this style (no --> in your code)
+\ Example: everything has next and prev for array access, so...
+\ method next
+\ method prev
+\ my-instance next ( does whatever next does to my-instance by late binding )
+
: method create does> body> >name lookup-method execute ;
--- a/softwords/softcore.bat
+++ b/softwords/softcore.bat
@@ -1,1 +1,1 @@
-perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr >..\softcore.c
+perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
--- a/softwords/softcore.fr
+++ b/softwords/softcore.fr
@@ -171,6 +171,33 @@
: debug ' debug-xt ;
: on-step ." S: " .s cr ;
+
+\ Submitted by lch.
+: strdup ( c-addr length -- c-addr2 length2 ior )
+ 0 locals| addr2 length c-addr | end-locals
+ length 1 + allocate
+ 0= if
+ to addr2
+ c-addr addr2 length move
+ addr2 length 0
+ else
+ 0 -1
+ endif
+ ;
+
+: strcat ( 2:a 2:b -- 2:new-a )
+ 0 locals| b-length b-u b-addr a-u a-addr | end-locals
+ b-u to b-length
+ b-addr a-addr a-u + b-length move
+ a-addr a-u b-length +
+ ;
+
+: strcpy ( 2:a 2:b -- 2:new-a )
+ locals| b-u b-addr a-u a-addr | end-locals
+ a-addr 0 b-addr b-u strcat
+ ;
+
+
previous \ lose hidden words from search order
\ ** E N D S O F T C O R E . F R
--- a/softwords/softcore.pl
+++ b/softwords/softcore.pl
@@ -127,10 +127,12 @@
void ficlCompileSoftCore(FICL_SYSTEM *pSys)
{FICL_VM *pVM = pSys->vmList;
+ CELL id = pVM->sourceID;
int ret = sizeof (softWords);
- assert(pVM);
-
+ assert(pVM);
+ pVM->sourceID.i = -1;
ret = ficlExec(pVM, softWords);
+ pVM->sourceID = id;
if (ret == VM_ERREXIT)
assert(FALSE);
return;
--- /dev/null
+++ b/softwords/softcore.py
@@ -1,0 +1,152 @@
+#! python
+# Convert forth source files to a giant C string
+
+import re;
+import sys;
+import time;
+
+
+print """/*******************************************************************
+** s o f t c o r e . c
+** Forth Inspired Command Language -
+** Words from CORE set written in FICL
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 27 December 1997
+** Last update: """ + time.ctime(time.time()) + """
+*******************************************************************/
+/*
+** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
+** Make changes to the .fr files in ficl/softwords instead.
+** This file contains definitions that are compiled into the
+** system dictionary by the first virtual machine to be created.
+** Created automagically by ficl/softwords/softcore.pl
+*/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the ficl release, please send
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+
+#include "ficl.h"
+
+static char softWords[] =
+#if FICL_WANT_SOFTWORDS"""
+
+escapedQuotes = re.compile( r'^"(.*)"$' )
+backslash = re.compile( r'^(.*[^\s])\s+\\(\s+[^\s].*)$' )
+parentheses = re.compile( r'^(.*[^\s])\s+\(\s[^)]+\)(\s+[^\s].*)?$' )
+
+
+commenting = 0;
+
+for a in (sys.argv[1:]):
+ f = open(a)
+ for line in f.readlines():
+
+ # trim all whitespace
+ line = line.strip();
+
+ # remove quotes around quoted lines
+ quoted = escapedQuotes.match(line)
+ if (quoted != None):
+ line = quoted.group(1).strip()
+
+ #
+ # emit lines beginnning with "\ **" as C comments
+ #
+ if (line[0:4] == "\\ **"):
+ if (commenting == 0):
+ print("/*")+ commenting = 1
+ print(line[2:])
+ continue
+
+ if (commenting == 1):
+ print "*/"
+
+ commenting = 0
+
+ # ignore empty lines
+ if (len(line) == 0):
+ continue
+
+ # pass commented preprocessor directives
+ # == lines starting with "\ #"
+ # (supports single line directives only)
+ if (line[0:3] == "\\ #"):
+ print(line[2:]) # include the leading #!
+ continue
+
+ # ignore remaining lines starting with comments
+ if (line[0] == "\\"):
+ continue
+
+ # remove trailing comments
+ trailingComment = backslash.match(line)
+ if (trailingComment != None):
+ line = trailingComment.group(1)
+
+ # remove ( comments ) in the middle
+ embeddedComment = parentheses.match(line)
+ if (embeddedComment != None):
+ line = embeddedComment.group(1)
+ if (embeddedComment.lastindex >= 2):
+ line = line + " " + embeddedComment.group(2).strip()
+
+ # quote double-quote characters
+ line = line.replace("\"", "\\\"")+
+ # emit whatever's left as quoted string fragments
+ print(" \"" + line + " \"");+
+
+print """#endif /* WANT_SOFTWORDS */
+ "quit ";
+
+
+void ficlCompileSoftCore(FICL_SYSTEM *pSys)
+{+ FICL_VM *pVM = pSys->vmList;
+ CELL id = pVM->sourceID;
+ int ret = sizeof (softWords);
+ assert(pVM);
+ pVM->sourceID.i = -1;
+ ret = ficlExec(pVM, softWords);
+ pVM->sourceID = id;
+ if (ret == VM_ERREXIT)
+ assert(FALSE);
+ return;
+}
+
+
+"""
--- /dev/null
+++ b/softwords/softcore.py.bat
@@ -1,0 +1,1 @@
+python softcore.py softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
--- a/stack.c
+++ b/stack.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 16 Oct 1997
-** $Id: stack.c,v 1.7 2001/06/12 08:24:35 jsadler Exp $
+** $Id: stack.c,v 1.8 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
--- a/sysdep.c
+++ b/sysdep.c
@@ -6,7 +6,7 @@
** Implementations of FICL external interface functions...
**
** (simple) port to Linux, Skip Carter 26 March 1998
-** $Id: sysdep.c,v 1.9 2001/07/24 05:01:24 jsadler Exp $
+** $Id: sysdep.c,v 1.10 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
--- a/sysdep.h
+++ b/sysdep.h
@@ -9,7 +9,7 @@
** FICL_ROBUST is enabled. This may require some consideration
** in firmware systems since assert often
** assumes stderr/stdout.
-** $Id: sysdep.h,v 1.7 2001/05/16 14:56:18 jsadler Exp $
+** $Id: sysdep.h,v 1.8 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -54,11 +54,20 @@
#include <assert.h>
#if defined(_WIN32)
- #define alloca(x) _alloca(x)
+ #include <stdio.h>
+ #ifndef alloca
+ #define alloca(x) _alloca(x)
+ #endif /* alloca */
#define stat _stat
#define getcwd _getcwd
#define chdir _chdir
+ #define unlink _unlink
+ #define fileno _fileno
+
+ #define FICL_HAVE_FTRUNCATE 1
+ extern int ftruncate(int fileno, size_t size);
#elif defined(linux)
+ #define FICL_HAVE_FTRUNCATE 1
#endif /* platform */
#if !defined IGNORE /* Macro to silence unused param warnings */
@@ -88,7 +97,6 @@
#define FICL_UNS unsigned long
#define BITS_PER_CELL 64
#define FICL_ALIGN 3
-
#endif
/*
@@ -177,6 +185,7 @@
#endif
#if (FICL_MINIMAL)
#define FICL_WANT_SOFTWORDS 0
+#define FICL_WANT_FILE 0
#define FICL_WANT_FLOAT 0
#define FICL_WANT_USER 0
#define FICL_WANT_LOCALS 0
@@ -190,9 +199,9 @@
/*
** FICL_PLATFORM_EXTEND
-** Includes words defined in ficlCompilePlatform (see win32.c for example)
+** Includes words defined in ficlCompilePlatform (see win32.c and unix.c for example)
*/
-#ifdef _WIN32
+#if defined (_WIN32)
#if !defined (FICL_PLATFORM_EXTEND)
#define FICL_PLATFORM_EXTEND 1
#endif
@@ -202,7 +211,18 @@
#define FICL_PLATFORM_EXTEND 0
#endif
+
/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a file system!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 1
+#endif
+
+/*
** FICL_WANT_FLOAT
** Includes a floating point stack for the VM, and words to do float operations.
** Contributed by Guy Carver
@@ -220,6 +240,14 @@
#endif
/*
+** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
** User variables: per-instance variables bound to the VM.
** Kinda like thread-local storage. Could be implemented in a
** VM private dictionary, but I've chosen the lower overhead
@@ -339,7 +367,7 @@
#endif
#if !defined FICL_DEFAULT_ENV
-#define FICL_DEFAULT_ENV 260
+#define FICL_DEFAULT_ENV 512
#endif
/*
@@ -362,14 +390,6 @@
#endif
/*
-** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
-** included as part of softcore.c)
-*/
-#if !defined FICL_EXTENDED_PREFIX
-#define FICL_EXTENDED_PREFIX 0
-#endif
-
-/*
** FICL_ALIGN is the power of two to which the dictionary
** pointer address must be aligned. This value is usually
** either 1 or 2, depending on the memory architecture
@@ -429,5 +449,16 @@
*/
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y);
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y);
+
+
+/*
+** FICL_HAVE_FTRUNCATE indicates whether the current OS supports
+** the ftruncate() function (available on most UNIXes). This
+** function is necessary to provide the complete File-Access wordset.
+*/
+#if !defined (FICL_HAVE_FTRUNCATE)
+#define FICL_HAVE_FTRUNCATE 0
+#endif
+
#endif /*__SYSDEP_H__*/
--- a/test/ficltest.fr
+++ b/test/ficltest.fr
@@ -71,6 +71,7 @@
{ exctest? abort -> -1 }testing refill
+\ from file loading
0 [if]
.( Error )
[else]
@@ -80,6 +81,11 @@
[then]
[then]
+\ refill from evaluate string
+{ -> }+{ s" 1 refill 2 " evaluate -> 1 0 2 }+
+
testing prefixes
{ 0x10 -> decimal 16 } { hex 0d10 -> decimal 10 }@@ -86,4 +92,15 @@
{ hex 100-> decimal 256 }
+testing number builder
+{ 1 -> 1 }+{ 3. -> 0 3 }+
+
+s" ficlwin" environment?
+[if]
+drop
+testing OOP support
load ooptest.fr
+[endif]
+
--- a/testmain.c
+++ b/testmain.c
@@ -1,6 +1,6 @@
/*
** stub main for testing FICL under Win32
-** $Id: testmain.c,v 1.10 2001/06/12 08:24:37 jsadler Exp $
+** $Id: testmain.c,v 1.11 2001/11/05 02:09:28 jsadler Exp $
*/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -326,7 +326,7 @@
buildTestInterface(pSys);
pVM = ficlNewVM(pSys);
- ret = ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
+ ret = ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
/*
** load file from cmd line...
@@ -336,7 +336,7 @@
sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
__try
{- ret = ficlExec(pVM, in);
+ ret = ficlEvaluate(pVM, in);
}
__except(1)
{--- a/tools.c
+++ b/tools.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - programming tools
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 20 June 2000
-** $Id: tools.c,v 1.8 2001/06/12 08:24:37 jsadler Exp $
+** $Id: tools.c,v 1.9 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -70,30 +70,13 @@
#endif
-/*
-** BREAKPOINT record.
-** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
-** that the breakpoint overwrote. This is restored to the dictionary when the
-** BP executes or gets cleared
-** address - the location of the breakpoint (address of the instruction that
-** has been replaced with the breakpoint trap
-** origXT - The original contents of the location with the breakpoint
-** Note: address is NULL when this breakpoint is empty
-*/
-typedef struct breakpoint
-{- void *address;
- FICL_WORD *origXT;
-} BREAKPOINT;
-static BREAKPOINT bpStep = {NULL, NULL};-
/**************************************************************************
v m S e t B r e a k
** Set a breakpoint at the current value of IP by
** storing that address in a BREAKPOINT record
**************************************************************************/
-static void vmSetBreak(FICL_VM *pVM, BREAKPOINT *pBP)
+static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
{FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
assert(pStep);
@@ -234,6 +217,13 @@
sprintf(cp, " s\" %.*s\"", sp->count, sp->text);
}
break;
+ case CSTRINGLIT:
+ {+ FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
+ pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
+ sprintf(cp, " c\" %.*s\"", sp->count, sp->text);
+ }
+ break;
case IF:
c = *++pc;
if (c.i > 0)
@@ -320,10 +310,12 @@
vmTextOut(pVM, pVM->pad, 1);
break;
+#if FICL_WANT_USER
case USER:
sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
break;
+#endif
case CONSTANT:
sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
@@ -381,7 +373,7 @@
** Run the colon code and set a breakpoint at the next instruction
*/
vmExecute(pVM, xt);
- vmSetBreak(pVM, &bpStep);
+ vmSetBreak(pVM, &(pVM->pSys->bpStep));
break;
default:
@@ -411,7 +403,7 @@
/*
** Now set a breakpoint at the next instruction
*/
- vmSetBreak(pVM, &bpStep);
+ vmSetBreak(pVM, &(pVM->pSys->bpStep));
return;
}
@@ -442,8 +434,8 @@
** assume that the next cell holds an instruction
** set a breakpoint there and return to the inner interp
*/
- bpStep.address = pVM->ip + 1;
- bpStep.origXT = pVM->ip[1];
+ pVM->pSys->bpStep.address = pVM->ip + 1;
+ pVM->pSys->bpStep.origXT = pVM->ip[1];
pVM->ip[1] = pStep;
break;
@@ -480,15 +472,15 @@
if (!pVM->fRestart)
{- assert(bpStep.address);
- assert(bpStep.origXT);
+ assert(pVM->pSys->bpStep.address);
+ assert(pVM->pSys->bpStep.origXT);
/*
** Clear the breakpoint that caused me to run
** Restore the original instruction at the breakpoint,
** and restore the IP
*/
- pVM->ip = (IPTYPE)bpStep.address;
- *pVM->ip = bpStep.origXT;
+ pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
+ *pVM->ip = pVM->pSys->bpStep.origXT;
/*
** If there's an onStep, do it
@@ -500,7 +492,7 @@
/*
** Print the name of the next instruction
*/
- pFW = bpStep.origXT;
+ pFW = pVM->pSys->bpStep.origXT;
sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
if (isPrimitive(pFW))
{@@ -784,7 +776,7 @@
**************************************************************************/
static void listEnv(FICL_VM *pVM)
{- FICL_DICT *dp = vmGetDict(pVM);
+ FICL_DICT *dp = pVM->pSys->envp;
FICL_HASH *pHash = dp->pForthWords;
FICL_WORD *wp;
unsigned i;
@@ -853,7 +845,6 @@
/*
** TOOLS and TOOLS EXT
*/
- dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
dictAppendWord(dp, "bye", bye, FW_DEFAULT);
dictAppendWord(dp, "forget", forget, FW_DEFAULT);
@@ -869,6 +860,7 @@
/*
** Ficl extras
*/
+ dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
dictAppendWord(dp, "env-constant",
envConstant, FW_DEFAULT);
--- /dev/null
+++ b/unix.c
@@ -1,0 +1,21 @@
+#include <string.h>
+#include <netinet/in.h>
+
+#include "ficl.h"
+
+
+
+unsigned long ficlNtohl(unsigned long number)
+{+ return ntohl(number);
+}
+
+
+
+
+void ficlCompilePlatform(FICL_DICT *dp)
+{+ return;
+}
+
+
--- a/vm.c
+++ b/vm.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - virtual machine methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: vm.c,v 1.10 2001/06/12 08:24:40 jsadler Exp $
+** $Id: vm.c,v 1.11 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** This file implements the virtual machine of FICL. Each virtual
@@ -440,18 +440,6 @@
return;
}
-
-
-/**************************************************************************
- v m S t e p
-** Single step the vm - equivalent to "step into" - used for debugging
-**************************************************************************/
-#if FICL_WANT_DEBUGGER
-void vmStep(FICL_VM *pVM)
-{- M_VM_STEP(pVM);
-}
-#endif
/**************************************************************************
--- a/win32.c
+++ b/win32.c
@@ -157,6 +157,7 @@
}
+#if 0
//**************************************************************
//Load forth file.
//ENTER: pVM = Pointer to forth virtual machine.
@@ -288,7 +289,36 @@
}
}
+#endif /* 0 */
+
+static void ficlWordGetTickCount(FICL_VM *pVM) /* ( -- ms ) */
+{+ stackPushINT(pVM->pStack, (int)GetTickCount());
+}
+
+
+static void ficlDebugBreak(FICL_VM *pVM) /* ( -- ) */
+{+ DebugBreak();
+ pVM = pVM;
+}
+
+
+static void ficlOutputDebugString(FICL_VM *pVM) /* ( c-addr u -- ) */
+{+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *buf = (char *)_alloca(length + 1);
+ memcpy(buf, address, length);
+ buf[length] = 0;
+
+ OutputDebugString(buf);
+}
+
+
+
/**************************************************************************
f i c l C o m p i l e P l a t f o r m
** Build Win32 platform extensions into the system dictionary
@@ -306,9 +336,71 @@
callNativeFunction,
FW_DEFAULT);
dictAppendWord(dp, "vcall", VCall, FW_DEFAULT);
+/*
dictAppendWord(dp, "include", include, FW_DEFAULT);
dictAppendWord(dp, "reinclude", reinclude, FW_DEFAULT);
+*/
+ dictAppendWord(dp, "GetTickCount", ficlWordGetTickCount, FW_DEFAULT);
+ dictAppendWord(dp, "debug-break", ficlDebugBreak, FW_DEFAULT);
+ dictAppendWord(dp, "output-debug-string", ficlOutputDebugString, FW_DEFAULT);
+
return;
}
+
+
+
+
+/*
+**
+** Heavy, undocumented wizardry here.
+**
+** In Win32, like most OSes, the buffered file I/O functions in the
+** C API (functions that take a FILE * like fopen()) are implemented
+** on top of the raw file I/O functions (functions that take an int,
+** like open()). However, in Win32, these functions in turn are
+** implemented on top of the Win32 native file I/O functions (functions
+** that take a HANDLE, like CreateFile()). This behavior is undocumented
+** but easy to deduce by reading the CRT/SRC directory.
+**
+** The below mishmash of typedefs and defines were copied from
+** CRT/SRC/INTERNAL.H.
+**
+** --lch
+*/
+typedef struct {+ long osfhnd; /* underlying OS file HANDLE */
+ char osfile; /* attributes of file (e.g., open in text mode?) */
+ char pipech; /* one char buffer for handles opened on pipes */
+#ifdef _MT
+ int lockinitflag;
+ CRITICAL_SECTION lock;
+#endif /* _MT */
+ } ioinfo;
+extern _CRTIMP ioinfo * __pioinfo[];
+
+#define IOINFO_L2E 5
+#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
+#define _pioinfo(i) ( __pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - \
+ 1)) )
+#define _osfhnd(i) ( _pioinfo(i)->osfhnd )
+
+
+int ftruncate(int fileno, size_t size)
+{+ HANDLE hFile = (HANDLE)_osfhnd(fileno);
+ if (SetFilePointer(hFile, size, NULL, FILE_BEGIN) != size)
+ return 0;
+ return !SetEndOfFile(hFile);
+}
+
+#if 0
+unsigned long ficlNtohl(unsigned long number)
+{+ return ntohl(number);
+}
+#endif
+
+
+
--- a/words.c
+++ b/words.c
@@ -4,7 +4,7 @@
** ANS Forth CORE word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: words.c,v 1.14 2001/06/12 08:24:31 jsadler Exp $
+** $Id: words.c,v 1.15 2001/11/05 02:09:28 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -64,46 +64,9 @@
static char destTag[] = "target";
static char origTag[] = "origin";
-/*
-** Pointers to various words in the dictionary
-** -- initialized by ficlCompileCore, below --
-** for use by compiling words. Colon definitions
-** in ficl are lists of pointers to words. A bit
-** simple-minded...
-*/
-static FICL_WORD *pBranchParen = NULL;
-static FICL_WORD *pDoParen = NULL;
-static FICL_WORD *pDoesParen = NULL;
-static FICL_WORD *pExitParen = NULL;
-static FICL_WORD *pIfParen = NULL;
-static FICL_WORD *pInterpret = NULL;
-static FICL_WORD *pLitParen = NULL;
-static FICL_WORD *pTwoLitParen = NULL;
-static FICL_WORD *pLoopParen = NULL;
-static FICL_WORD *pPLoopParen = NULL;
-static FICL_WORD *pPlusStore = NULL;
-static FICL_WORD *pQDoParen = NULL;
-static FICL_WORD *pSemiParen = NULL;
-static FICL_WORD *pStore = NULL;
-static FICL_WORD *pStringLit = NULL;
-
#if FICL_WANT_LOCALS
-static FICL_WORD *pGetLocalParen= NULL;
-static FICL_WORD *pGet2LocalParen= NULL;
-static FICL_WORD *pGetLocal0 = NULL;
-static FICL_WORD *pGetLocal1 = NULL;
-static FICL_WORD *pToLocalParen = NULL;
-static FICL_WORD *pTo2LocalParen = NULL;
-static FICL_WORD *pToLocal0 = NULL;
-static FICL_WORD *pToLocal1 = NULL;
-static FICL_WORD *pLinkParen = NULL;
-static FICL_WORD *pUnLinkParen = NULL;
-static FICL_INT nLocals = 0;
-static CELL *pMarkLocals = NULL;
-
static void doLocalIm(FICL_VM *pVM);
static void do2LocalIm(FICL_VM *pVM);
-
#endif
@@ -224,6 +187,8 @@
** Attempts to convert the NULL terminated string in the VM's pad to
** a number using the VM's current base. If successful, pushes the number
** onto the param stack and returns TRUE. Otherwise, returns FALSE.
+** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
+** the standard for DOUBLE wordset.
**************************************************************************/
int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
@@ -230,6 +195,7 @@
{FICL_INT accum = 0;
char isNeg = FALSE;
+ char hasDP = FALSE;
unsigned base = pVM->base;
char *cp = SI_PTR(si);
FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
@@ -255,7 +221,13 @@
}
}
- if (count == 0)
+ if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
+ {+ hasDP = TRUE;
+ count--;
+ }
+
+ if (count == 0) /* detect "+", "-", ".", "+." etc */
return FALSE;
while ((count--) && ((ch = *cp++) != '\0'))
@@ -274,6 +246,9 @@
accum = accum * base + digit;
}
+ if (hasDP) /* simple (required) DOUBLE support */
+ PUSHINT(0);
+
if (isNeg)
accum = -accum;
@@ -482,7 +457,7 @@
markControlTag(pVM, colonTag);
dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
#if FICL_WANT_LOCALS
- nLocals = 0;
+ pVM->pSys->nLocals = 0;
#endif
return;
}
@@ -528,21 +503,21 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pSemiParen);
+ assert(pVM->pSys->pSemiParen);
matchControlTag(pVM, colonTag);
#if FICL_WANT_LOCALS
- assert(pUnLinkParen);
- if (nLocals > 0)
+ assert(pVM->pSys->pUnLinkParen);
+ if (pVM->pSys->nLocals > 0)
{FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
}
- nLocals = 0;
+ pVM->pSys->nLocals = 0;
#endif
- dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
pVM->state = INTERPRET;
dictUnsmudge(dp);
return;
@@ -567,16 +542,16 @@
static void exitCoIm(FICL_VM *pVM)
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pExitParen);
+ assert(pVM->pSys->pExitParen);
IGNORE(pVM);
#if FICL_WANT_LOCALS
- if (nLocals > 0)
+ if (pVM->pSys->nLocals > 0)
{- dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
}
#endif
- dictAppendCell(dp, LVALUEtoCELL(pExitParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
return;
}
@@ -696,6 +671,172 @@
/**************************************************************************
+ s t r l e n
+** FICL ( c-string -- length )
+**
+** Returns the length of a C-style (zero-terminated) string.
+**
+** --lch
+**/
+static void ficlStrlen(FICL_VM *ficlVM)
+ {+ char *address = (char *)stackPopPtr(ficlVM->pStack);
+ stackPushINT(ficlVM->pStack, strlen(address));
+ }
+
+
+/**************************************************************************
+ s p r i n t f
+** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
+** Similar to the C sprintf() function. It formats into a buffer based on
+** a "format" string. Each character in the format string is copied verbatim
+** to the output buffer, until SPRINTF encounters a percent sign ("%").+** SPRINTF then skips the percent sign, and examines the next character
+** (the "format character"). Here are the valid format characters:
+** s - read a C-ADDR U-LENGTH string from the stack and copy it to
+** the buffer
+** d - read a cell from the stack, format it as a string (base-10,
+** signed), and copy it to the buffer
+** x - same as d, except in base-16
+** u - same as d, but unsigned
+** % - output a literal percent-sign to the buffer
+** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
+** written, and a flag indicating whether or not it ran out of space while
+** writing to the output buffer (TRUE if it ran out of space).
+**
+** If SPRINTF runs out of space in the buffer to store the formatted string,
+** it still continues parsing, in an effort to preserve your stack (otherwise
+** it might leave uneaten arguments behind).
+**
+** --lch
+**************************************************************************/
+static void ficlSprintf(FICL_VM *pVM) /* */
+{+ int bufferLength = stackPopINT(pVM->pStack);
+ char *buffer = (char *)stackPopPtr(pVM->pStack);
+ char *bufferStart = buffer;
+
+ int formatLength = stackPopINT(pVM->pStack);
+ char *format = (char *)stackPopPtr(pVM->pStack);
+ char *formatStop = format + formatLength;
+
+ int base = 10;
+ int unsignedInteger = FALSE;
+
+ int append = FICL_TRUE;
+
+ while (format < formatStop)
+ {+ char scratch[64];
+ char *source;
+ int actualLength;
+ int desiredLength;
+ int leadingZeroes;
+
+
+ if (*format != '%')
+ {+ source = format;
+ actualLength = desiredLength = 1;
+ leadingZeroes = 0;
+ }
+ else
+ {+ format++;
+ if (format == formatStop)
+ break;
+
+ leadingZeroes = (*format == '0');
+ if (leadingZeroes)
+ {+ format++;
+ if (format == formatStop)
+ break;
+ }
+
+ desiredLength = isdigit(*format);
+ if (desiredLength)
+ {+ desiredLength = strtoul(format, &format, 10);
+ if (format == formatStop)
+ break;
+ }
+ else if (*format == '*')
+ {+ desiredLength = stackPopINT(pVM->pStack);
+ format++;
+ if (format == formatStop)
+ break;
+ }
+
+
+ switch (*format)
+ {+ case 's':
+ case 'S':
+ {+ actualLength = stackPopINT(pVM->pStack);
+ source = (char *)stackPopPtr(pVM->pStack);
+ break;
+ }
+ case 'x':
+ case 'X':
+ base = 16;
+ case 'u':
+ case 'U':
+ unsignedInteger = TRUE;
+ case 'd':
+ case 'D':
+ {+ int integer = stackPopINT(pVM->pStack);
+ if (unsignedInteger)
+ ultoa(integer, scratch, base);
+ else
+ ltoa(integer, scratch, base);
+ base = 10;
+ unsignedInteger = FALSE;
+ source = scratch;
+ actualLength = strlen(scratch);
+ break;
+ }
+ case '%':
+ source = format;
+ actualLength = 1;
+ default:
+ continue;
+ }
+ }
+
+ if (append == FICL_TRUE)
+ {+ if (!desiredLength)
+ desiredLength = actualLength;
+ if (desiredLength > bufferLength)
+ {+ append = FICL_FALSE;
+ desiredLength = bufferLength;
+ }
+ while (desiredLength > actualLength)
+ {+ *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
+ bufferLength--;
+ desiredLength--;
+ }
+ memcpy(buffer, source, actualLength);
+ buffer += actualLength;
+ bufferLength -= actualLength;
+ }
+
+ format++;
+ }
+
+ stackPushPtr(pVM->pStack, bufferStart);
+ stackPushINT(pVM->pStack, buffer - bufferStart);
+ stackPushINT(pVM->pStack, append);
+}
+
+
+/**************************************************************************
d u p & f r i e n d s
**
**************************************************************************/
@@ -1081,9 +1222,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pIfParen);
+ assert(pVM->pSys->pIfParen);
- dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
markBranch(dp, pVM, origTag);
dictAppendUNS(dp, 1);
return;
@@ -1137,9 +1278,9 @@
FICL_INT offset;
FICL_DICT *dp = vmGetDict(pVM);
- assert(pBranchParen);
+ assert(pVM->pSys->pBranchParen);
/* (1) compile branch runtime */
- dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
matchControlTag(pVM, origTag);
patchAddr =
(CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
@@ -1305,7 +1446,7 @@
#endif
#if FICL_WANT_LOCALS
- if (nLocals > 0)
+ if (pVM->pSys->nLocals > 0)
{tempFW = ficlLookupLoc(pVM->pSys, si);
}
@@ -1440,9 +1581,9 @@
static void literalIm(FICL_VM *pVM)
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pLitParen);
+ assert(pVM->pSys->pLitParen);
- dictAppendCell(dp, LVALUEtoCELL(pLitParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
dictAppendCell(dp, stackPop(pVM->pStack));
return;
@@ -1452,9 +1593,9 @@
static void twoLiteralIm(FICL_VM *pVM)
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pTwoLitParen);
+ assert(pVM->pSys->pTwoLitParen);
- dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
dictAppendCell(dp, stackPop(pVM->pStack));
dictAppendCell(dp, stackPop(pVM->pStack));
@@ -1625,9 +1766,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pDoParen);
+ assert(pVM->pSys->pDoParen);
- dictAppendCell(dp, LVALUEtoCELL(pDoParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
/*
** Allot space for a pointer to the end
** of the loop - "leave" uses this...
@@ -1665,9 +1806,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pQDoParen);
+ assert(pVM->pSys->pQDoParen);
- dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
/*
** Allot space for a pointer to the end
** of the loop - "leave" uses this...
@@ -1735,9 +1876,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pLoopParen);
+ assert(pVM->pSys->pLoopParen);
- dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
resolveBackBranch(dp, pVM, doTag);
resolveAbsBranch(dp, pVM, leaveTag);
return;
@@ -1748,9 +1889,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pPLoopParen);
+ assert(pVM->pSys->pPLoopParen);
- dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
resolveBackBranch(dp, pVM, doTag);
resolveAbsBranch(dp, pVM, leaveTag);
return;
@@ -2176,6 +2317,42 @@
}
+static void cstringLit(FICL_VM *pVM)
+{+ FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
+
+ char *cp = sp->text;
+ cp += sp->count + 1;
+ cp = alignPtr(cp);
+ pVM->ip = (IPTYPE)(void *)cp;
+
+ stackPushPtr(pVM->pStack, sp);
+ return;
+}
+
+
+static void cstringQuoteIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = vmGetDict(pVM);
+
+ if (pVM->state == INTERPRET)
+ {+ FICL_STRING *sp = (FICL_STRING *) dp->here;
+ vmGetString(pVM, sp, '\"');
+ stackPushPtr(pVM->pStack, sp);
+ /* move HERE past string so it doesn't get overwritten. --lch */
+ dictAllot(dp, sp->count + sizeof(FICL_COUNT));
+ }
+ else /* COMPILE state */
+ {+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
+ dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
+ dictAlign(dp);
+ }
+
+ return;
+}
+
/**************************************************************************
d o t Q u o t e
** IMMEDIATE word that compiles a string literal for later display
@@ -2211,7 +2388,7 @@
FICL_DICT *dp = vmGetDict(pVM);
FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
assert(pType);
- dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
dictAlign(dp);
dictAppendCell(dp, LVALUEtoCELL(pType));
@@ -2268,7 +2445,7 @@
u = POPUNS();
cp = POPPTR();
- dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
cpDest = (char *) dp->here;
*cpDest++ = (char) u;
@@ -2360,19 +2537,19 @@
{FICL_DICT *dp = vmGetDict(pVM);
#if FICL_WANT_LOCALS
- assert(pUnLinkParen);
- if (nLocals > 0)
+ assert(pVM->pSys->pUnLinkParen);
+ if (pVM->pSys->nLocals > 0)
{FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
}
- nLocals = 0;
+ pVM->pSys->nLocals = 0;
#endif
IGNORE(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
return;
}
@@ -2785,9 +2962,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pIfParen);
+ assert(pVM->pSys->pIfParen);
- dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
resolveBackBranch(dp, pVM, destTag);
return;
}
@@ -2796,9 +2973,9 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pIfParen);
+ assert(pVM->pSys->pIfParen);
- dictAppendCell(dp, LVALUEtoCELL(pIfParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
markBranch(dp, pVM, origTag);
twoSwap(pVM);
dictAppendUNS(dp, 1);
@@ -2809,8 +2986,8 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
+ assert(pVM->pSys->pBranchParen);
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
/* expect "begin" branch marker */
resolveBackBranch(dp, pVM, destTag);
@@ -2824,8 +3001,8 @@
{FICL_DICT *dp = vmGetDict(pVM);
- assert(pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
+ assert(pVM->pSys->pBranchParen);
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
/* expect "begin" branch marker */
resolveBackBranch(dp, pVM, destTag);
@@ -2957,7 +3134,7 @@
vmCheckStack(pVM,2,1);
#endif
- envp = ficlGetEnv(pVM->pSys);
+ envp = pVM->pSys->envp;
len = (FICL_COUNT)POPUNS();
cp = POPPTR();
@@ -3033,7 +3210,7 @@
}
else /* COMPILE state */
{- dictAppendCell(dp, LVALUEtoCELL(pStringLit));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
dictAlign(dp);
}
@@ -3202,17 +3379,10 @@
** string, the values returned by FIND while compiling may differ from
** those returned while not compiling.
**************************************************************************/
-static void find(FICL_VM *pVM)
+static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
{- FICL_STRING *sp;
FICL_WORD *pFW;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
- sp = POPPTR();
- SI_PFS(si, sp);
pFW = dictLookup(vmGetDict(pVM), si);
if (pFW)
{@@ -3221,7 +3391,7 @@
}
else
{- PUSHPTR(sp);
+ PUSHPTR(returnForFailure);
PUSHUNS(0);
}
return;
@@ -3230,6 +3400,52 @@
/**************************************************************************
+ f i n d
+** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
+** Find the definition named in the counted string at c-addr. If the
+** definition is not found, return c-addr and zero. If the definition is
+** found, return its execution token xt. If the definition is immediate,
+** also return one (1), otherwise also return minus-one (-1). For a given
+** string, the values returned by FIND while compiling may differ from
+** those returned while not compiling.
+**************************************************************************/
+static void cFind(FICL_VM *pVM)
+{+ FICL_STRING *sp;
+ STRINGINFO si;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,2);
+#endif
+ sp = POPPTR();
+ SI_PFS(si, sp);
+ do_find(pVM, si, sp);
+}
+
+
+
+/**************************************************************************
+ s f i n d
+** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
+** Like FIND, but takes "c-addr u" for the string.
+**************************************************************************/
+static void sFind(FICL_VM *pVM)
+{+ STRINGINFO si;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,2);
+#endif
+
+ si.count = stackPopINT(pVM->pStack);
+ si.cp = stackPopPtr(pVM->pStack);
+
+ do_find(pVM, si, NULL);
+}
+
+
+
+/**************************************************************************
f m S l a s h M o d
** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
@@ -3649,19 +3865,19 @@
FICL_WORD *pFW;
#if FICL_WANT_LOCALS
- if ((nLocals > 0) && (pVM->state == COMPILE))
+ if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
{FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
pFW = dictLookup(pLoc, si);
if (pFW && (pFW->code == doLocalIm))
{- dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
}
else if (pFW && pFW->code == do2LocalIm)
{- dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
}
@@ -3668,7 +3884,7 @@
}
#endif
- assert(pStore);
+ assert(pVM->pSys->pStore);
pFW = dictLookup(dp, si);
if (!pFW)
@@ -3683,7 +3899,7 @@
{PUSHPTR(&pFW->param[0]);
literalIm(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pStore));
+ dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
}
return;
}
@@ -3785,15 +4001,15 @@
if (nLocal == 0)
{- dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
}
else if (nLocal == 1)
{- dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
}
else
{- dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
dictAppendCell(pDict, LVALUEtoCELL(nLocal));
}
}
@@ -3826,7 +4042,6 @@
**************************************************************************/
static void localParen(FICL_VM *pVM)
{- static CELL *pMark = NULL;
FICL_DICT *pDict;
STRINGINFO si;
#if FICL_ROBUST > 1
@@ -3840,38 +4055,38 @@
if (SI_COUNT(si) > 0)
{ /* add a local to the **locals** dict and update nLocals */FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (nLocals >= FICL_MAX_LOCALS)
+ if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
{vmThrowErr(pVM, "Error: out of local space");
}
dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
+ dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
- if (nLocals == 0)
+ if (pVM->pSys->nLocals == 0)
{ /* compile code to create a local stack frame */- dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
/* save location in dictionary for #locals */
- pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ pVM->pSys->pMarkLocals = pDict->here;
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
/* compile code to initialize first local */
- dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
}
- else if (nLocals == 1)
+ else if (pVM->pSys->nLocals == 1)
{- dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
}
else
{- dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
}
- nLocals++;
+ (pVM->pSys->nLocals)++;
}
- else if (nLocals > 0)
+ else if (pVM->pSys->nLocals > 0)
{ /* write nLocals to (link) param area in dictionary */- *(FICL_INT *)pMarkLocals = nLocals;
+ *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
}
return;
@@ -3899,7 +4114,7 @@
}
else
{- dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
dictAppendCell(pDict, LVALUEtoCELL(nLocal));
}
return;
@@ -3925,30 +4140,30 @@
if (SI_COUNT(si) > 0)
{ /* add a local to the **locals** dict and update nLocals */FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (nLocals >= FICL_MAX_LOCALS)
+ if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
{vmThrowErr(pVM, "Error: out of local space");
}
dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(nLocals));
+ dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
- if (nLocals == 0)
+ if (pVM->pSys->nLocals == 0)
{ /* compile code to create a local stack frame */- dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
/* save location in dictionary for #locals */
- pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ pVM->pSys->pMarkLocals = pDict->here;
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
}
- dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocals));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- nLocals += 2;
+ pVM->pSys->nLocals += 2;
}
- else if (nLocals > 0)
+ else if (pVM->pSys->nLocals > 0)
{ /* write nLocals to (link) param area in dictionary */- *(FICL_INT *)pMarkLocals = nLocals;
+ *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
}
return;
@@ -3970,7 +4185,7 @@
** lesser numeric value than the corresponding character in the string specified
** by c-addr2 u2 and one (1) otherwise.
**************************************************************************/
-static void compareString(FICL_VM *pVM)
+static void compareInternal(FICL_VM *pVM, int caseInsensitive)
{char *cp1, *cp2;
FICL_UNS u1, u2, uMin;
@@ -3985,7 +4200,14 @@
uMin = (u1 < u2)? u1 : u2;
for ( ; (uMin > 0) && (n == 0); uMin--)
{- n = (int)(*cp1++ - *cp2++);
+ char c1 = *cp1++;
+ char c2 = *cp2++;
+ if (caseInsensitive)
+ {+ c1 = (char)tolower(c1);
+ c2 = (char)tolower(c2);
+ }
+ n = (int)(c1 - c2);
}
if (n == 0)
@@ -4001,7 +4223,31 @@
}
+static void compareString(FICL_VM *pVM)
+{+ compareInternal(pVM, FALSE);
+}
+
+
+static void compareStringInsensitive(FICL_VM *pVM)
+{+ compareInternal(pVM, TRUE);
+}
+
+
/**************************************************************************
+ p a d
+** CORE EXT ( -- c-addr )
+** c-addr is the address of a transient region that can be used to hold
+** data for intermediate processing.
+**************************************************************************/
+static void pad(FICL_VM *pVM)
+{+ stackPushPtr(pVM->pStack, pVM->pad);
+}
+
+
+/**************************************************************************
s o u r c e - i d
** CORE EXT, FILE ( -- 0 | -1 | fileid )
** Identifies the input source as follows:
@@ -4066,8 +4312,6 @@
static void ficlCatch(FICL_VM *pVM)
{- static FICL_WORD *pQuit = NULL;
-
int except;
jmp_buf vmState;
FICL_VM VM;
@@ -4075,11 +4319,8 @@
FICL_STACK rStack;
FICL_WORD *pFW;
- if (!pQuit)
- pQuit = ficlLookup(pVM->pSys, "exit-inner");
-
assert(pVM);
- assert(pQuit);
+ assert(pVM->pSys->pExitInner);
/*
@@ -4126,7 +4367,7 @@
** the XT
*/
case 0:
- vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */
+ vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
vmExecute(pVM, pFW);
vmInnerLoop(pVM);
break;
@@ -4301,8 +4542,11 @@
{LOOP, loopParen}, {PLOOP, plusLoopParen}, {QDO, qDoParen},+ {CSTRINGLIT, cstringLit}, {STRINGLIT, stringLit},+#if FICL_WANT_USER
{USER, userParen},+#endif
{VARIABLE, variableParen},};
@@ -4331,11 +4575,12 @@
FICL_DICT *dp = pSys->dp;
assert (dp);
+
/*
** CORE word set
** see softcore.c for definitions of: abs bl space spaces abort"
*/
- pStore =
+ pSys->pStore =
dictAppendWord(dp, "!", store, FW_DEFAULT);
dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
@@ -4388,6 +4633,7 @@
dictAppendWord(dp, "base", base, FW_DEFAULT);
dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
dictAppendWord(dp, "c!", cStore, FW_DEFAULT);
+ dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
dictAppendWord(dp, "c,", cComma, FW_DEFAULT);
dictAppendWord(dp, "c@", cFetch, FW_DEFAULT);
dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT);
@@ -4412,7 +4658,7 @@
dictAppendWord(dp, "execute", execute, FW_DEFAULT);
dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED);
dictAppendWord(dp, "fill", fill, FW_DEFAULT);
- dictAppendWord(dp, "find", find, FW_DEFAULT);
+ dictAppendWord(dp, "find", cFind, FW_DEFAULT);
dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT);
dictAppendWord(dp, "here", here, FW_DEFAULT);
dictAppendWord(dp, "hex", hex, FW_DEFAULT);
@@ -4435,6 +4681,7 @@
dictAppendWord(dp, "negate", negate, FW_DEFAULT);
dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT);
dictAppendWord(dp, "over", over, FW_DEFAULT);
+ dictAppendWord(dp, "pad", pad, FW_DEFAULT);
dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED);
dictAppendWord(dp, "quit", quit, FW_DEFAULT);
dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
@@ -4470,7 +4717,7 @@
** CORE EXT word set...
** see softcore.fr for other definitions
*/
- dictAppendWord(dp, ".(", dotParen, FW_DEFAULT);+ dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
@@ -4528,28 +4775,28 @@
** see softcore.c for implementation of locals|
*/
#if FICL_WANT_LOCALS
- pLinkParen =
+ pSys->pLinkParen =
dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
- pUnLinkParen =
+ pSys->pUnLinkParen =
dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
- pGetLocalParen =
+ pSys->pGetLocalParen =
dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
- pToLocalParen =
+ pSys->pToLocalParen =
dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
- pGetLocal0 =
+ pSys->pGetLocal0 =
dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
- pToLocal0 =
+ pSys->pToLocal0 =
dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
- pGetLocal1 =
+ pSys->pGetLocal1 =
dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
- pToLocal1 =
+ pSys->pToLocal1 =
dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
- pGet2LocalParen =
+ pSys->pGet2LocalParen =
dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
- pTo2LocalParen =
+ pSys->pTo2LocalParen =
dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
@@ -4580,9 +4827,18 @@
ficlCompileTools(pSys);
/*
+ ** FILE and FILE EXT
+ */
+#if FICL_WANT_FILE
+ ficlCompileFile(pSys);
+#endif
+
+ /*
** Ficl extras
*/
+#if FICL_WANT_FLOAT
dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT);
+#endif
dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT);
dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT);
dictAppendWord(dp, ">name", toName, FW_DEFAULT);
@@ -4590,6 +4846,7 @@
addParseStep, FW_DEFAULT);
dictAppendWord(dp, "body>", fromBody, FW_DEFAULT);
dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */
+ dictAppendWord(dp, "compare-insensitive", compareStringInsensitive, FW_DEFAULT); /* STRING */
dictAppendWord(dp, "compile-only",
compileOnly, FW_DEFAULT);
dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
@@ -4596,7 +4853,10 @@
dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
dictAppendWord(dp, "hash", hash, FW_DEFAULT);
dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
+ dictAppendWord(dp, "sfind", sFind, FW_DEFAULT);
dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
+ dictAppendWord(dp, "sprintf", ficlSprintf, FW_DEFAULT);
+ dictAppendWord(dp, "strlen", ficlStrlen, FW_DEFAULT);
dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
dictAppendWord(dp, "q!", quadStore, FW_DEFAULT);
dictAppendWord(dp, "w@", wFetch, FW_DEFAULT);
@@ -4606,35 +4866,38 @@
dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
#endif
+
/*
** internal support words
*/
dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
- pExitParen =
+ pSys->pExitParen =
dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
- pSemiParen =
+ pSys->pSemiParen =
dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
- pLitParen =
+ pSys->pLitParen =
dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
- pTwoLitParen =
+ pSys->pTwoLitParen =
dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
- pStringLit =
+ pSys->pStringLit =
dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
- pIfParen =
+ pSys->pCStringLit =
+ dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
+ pSys->pIfParen =
dictAppendWord(dp, "(if)", ifParen, FW_COMPILE);
- pBranchParen =
+ pSys->pBranchParen =
dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
- pDoParen =
+ pSys->pDoParen =
dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
- pDoesParen =
+ pSys->pDoesParen =
dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
- pQDoParen =
+ pSys->pQDoParen =
dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
- pLoopParen =
+ pSys->pLoopParen =
dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
- pPLoopParen =
+ pSys->pPLoopParen =
dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
- pInterpret =
+ pSys->pInterpret =
dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
dictAppendWord(dp, "lookup", lookup, FW_DEFAULT);
dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
@@ -4641,7 +4904,15 @@
dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
dictAppendWord(dp, "(parse-step)",
parseStepParen, FW_DEFAULT);
+ pSys->pExitInner =
dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
+
+ /*
+ ** Set up system's outer interpreter loop - maybe this should be in initSystem?
+ */
+ pSys->pInterp[0] = pSys->pInterpret;
+ pSys->pInterp[1] = pSys->pBranchParen;
+ pSys->pInterp[2] = (FICL_WORD *)(void *)(-2);
assert(dictCellsAvail(dp) > 0);