aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPedro F. Giffuni <pfg@FreeBSD.org>2015-05-12 03:27:06 +0000
committerPedro F. Giffuni <pfg@FreeBSD.org>2015-05-12 03:27:06 +0000
commitf4e75c6395310fa4b119d3eaa9a4a9f8913df200 (patch)
tree2b015c205d81fa2431f0c36d7d9e903088a56d1c
parentbe98e1ae3decabdd852fbe6496166aaa9acfbf9e (diff)
downloadsrc-vendor/ficl.tar.gz
src-vendor/ficl.zip
Update to ficl 4.1.0 (latest release on sourceforge)vendor/ficl/4.1.0vendor/ficl
Notes
Notes: svn path=/vendor/ficl/dist/; revision=282803 svn path=/vendor/ficl/4.1.0/; revision=282804; tag=vendor/ficl/4.1.0
-rw-r--r--Makefile60
-rw-r--r--Makefile.ansi56
-rw-r--r--Makefile.linux30
-rw-r--r--ReadMe.txt20
-rw-r--r--bit.c49
-rw-r--r--callback.c76
-rw-r--r--compatibility.c284
-rw-r--r--contrib/xclasses/readme.txt111
-rw-r--r--contrib/xclasses/xclasses.py870
-rw-r--r--dict.c836
-rw-r--r--dictionary.c851
-rw-r--r--doc/Logo.jpgbin2349 -> 0 bytes
-rw-r--r--doc/api.html401
-rw-r--r--doc/articles/ficlddj.pdf (renamed from doc/ficlddj.PDF)bin34088 -> 34088 bytes
-rw-r--r--doc/articles/jwsforml.pdf (renamed from doc/jwsforml.PDF)bin140379 -> 140379 bytes
-rw-r--r--doc/articles/oo_in_c.html (renamed from doc/oo_in_c.html)0
-rw-r--r--doc/articles/sigplan9906.doc (renamed from doc/sigplan9906.doc)bin75776 -> 75776 bytes
-rw-r--r--doc/debugger.html259
-rw-r--r--doc/dpans.html1037
-rw-r--r--doc/favicon.icobin1078 -> 894 bytes
-rw-r--r--doc/ficl.html2754
-rw-r--r--doc/ficl1.icobin3310 -> 0 bytes
-rw-r--r--doc/ficl_debug.html111
-rw-r--r--doc/ficl_guts.htm69
-rw-r--r--doc/ficl_loc.html161
-rw-r--r--doc/ficl_logo.jpgbin2349 -> 0 bytes
-rw-r--r--doc/ficl_oop.html1387
-rw-r--r--doc/ficl_parse.html197
-rw-r--r--doc/ficlheader.js19
-rw-r--r--doc/graphics/4ring.gifbin0 -> 1247 bytes
-rw-r--r--doc/graphics/ficl.4.128.jpgbin0 -> 30958 bytes
-rw-r--r--doc/graphics/ficl.4.64.jpgbin0 -> 17200 bytes
-rw-r--r--doc/graphics/ficl.4.96.jpgbin0 -> 23710 bytes
-rw-r--r--doc/graphics/ficl_oop.jpg (renamed from doc/ficl_oop.jpg)bin63155 -> 63155 bytes
-rw-r--r--doc/graphics/ficl_top.jpg (renamed from doc/ficl_top.jpg)bin51512 -> 51512 bytes
-rw-r--r--doc/graphics/sourceforge.jpgbin0 -> 2615 bytes
-rw-r--r--doc/index.html492
-rw-r--r--doc/license.html103
-rw-r--r--doc/links.html318
-rw-r--r--doc/locals.html253
-rw-r--r--doc/oop.html1640
-rw-r--r--doc/parsesteps.html388
-rw-r--r--doc/primer.txt1164
-rw-r--r--doc/releases.html1267
-rw-r--r--doc/skey.gifbin4364 -> 0 bytes
-rw-r--r--doc/source/api.ht250
-rw-r--r--doc/source/debugger.ht157
-rw-r--r--doc/source/dpans.ht589
-rw-r--r--doc/source/ficl.ht1257
-rw-r--r--doc/source/generate.py244
-rw-r--r--doc/source/index.ht244
-rw-r--r--doc/source/license.ht47
-rw-r--r--doc/source/links.ht156
-rw-r--r--doc/source/locals.ht133
-rw-r--r--doc/source/oop.ht1224
-rw-r--r--doc/source/parsesteps.ht234
-rw-r--r--doc/source/releases.ht (renamed from doc/ficl_rel.html)729
-rw-r--r--doc/source/upgrading.ht349
-rw-r--r--doc/upgrading.html808
-rw-r--r--double.c479
-rw-r--r--extras.c267
-rw-r--r--ficl.c691
-rw-r--r--ficl.dsp301
-rw-r--r--ficl.dsw88
-rw-r--r--ficl.h1995
-rw-r--r--ficlcompatibility.h463
-rw-r--r--ficldll.def176
-rw-r--r--ficldll.dsp219
-rw-r--r--ficlexe.dsp206
-rw-r--r--ficllib.dsp296
-rw-r--r--ficllocal.h8
-rw-r--r--ficlplatform/alpha.h27
-rw-r--r--ficlplatform/ansi.c64
-rw-r--r--ficlplatform/ansi.h19
-rw-r--r--ficlplatform/ficlexports.txt168
-rw-r--r--ficlplatform/makedef.py33
-rw-r--r--ficlplatform/unix.c75
-rw-r--r--ficlplatform/unix.h46
-rw-r--r--ficlplatform/win32.c413
-rw-r--r--ficlplatform/win32.h64
-rw-r--r--ficltokens.h228
-rw-r--r--fileaccess.c364
-rw-r--r--float.c926
-rw-r--r--hash.c163
-rw-r--r--lzcompress.c202
-rw-r--r--lzuncompress.c94
-rw-r--r--main.c78
-rw-r--r--math64.c559
-rw-r--r--math64.h86
-rw-r--r--prefix.c131
-rw-r--r--primitives.c3513
-rw-r--r--search.c280
-rw-r--r--softcore.c3557
-rw-r--r--softcore/classes.fr (renamed from softwords/classes.fr)344
-rw-r--r--softcore/ficl.fr67
-rw-r--r--softcore/ficlclass.fr (renamed from softwords/ficlclass.fr)168
-rw-r--r--softcore/ficllocal.fr (renamed from softwords/ficllocal.fr)92
-rw-r--r--softcore/fileaccess.fr (renamed from softwords/fileaccess.fr)45
-rw-r--r--softcore/forml.fr (renamed from softwords/forml.fr)144
-rw-r--r--softcore/ifbrack.fr (renamed from softwords/ifbrack.fr)96
-rw-r--r--softcore/jhlocal.fr171
-rw-r--r--softcore/make.bat22
-rw-r--r--softcore/makefile11
-rw-r--r--softcore/makesoftcore.c244
-rw-r--r--softcore/marker.fr (renamed from softwords/marker.fr)50
-rw-r--r--softcore/oo.fr (renamed from softwords/oo.fr)1393
-rw-r--r--softcore/prefix.fr (renamed from softwords/prefix.fr)104
-rw-r--r--softcore/softcore.fr (renamed from softwords/softcore.fr)359
-rw-r--r--softcore/string.fr (renamed from softwords/string.fr)297
-rw-r--r--softcore/win32.fr211
-rw-r--r--softwords/jhlocal.fr103
-rw-r--r--softwords/makefile9
-rw-r--r--softwords/oo.fr.bak678
-rw-r--r--softwords/softcore.bat1
-rwxr-xr-xsoftwords/softcore.pl144
-rw-r--r--softwords/softcore.py152
-rw-r--r--softwords/softcore.py.bat1
-rw-r--r--softwords/win32.fr10
-rw-r--r--stack.c269
-rw-r--r--sysdep.c409
-rw-r--r--sysdep.h465
-rw-r--r--system.c466
-rw-r--r--test/asm68k.4th608
-rw-r--r--test/core.fr1994
-rw-r--r--test/fib.fr24
-rw-r--r--test/ficltest.fr212
-rw-r--r--test/ooptest.fr146
-rw-r--r--test/prefix.fr14
-rw-r--r--test/sarray.fr34
-rw-r--r--test/testcase.fr167
-rw-r--r--test/tester.fr118
-rw-r--r--test/vocab.fr64
-rw-r--r--testmain.c367
-rw-r--r--tools.c965
-rw-r--r--unix.c21
-rw-r--r--utility.c262
-rw-r--r--vm.c3097
-rw-r--r--win32.c406
-rw-r--r--word.c144
-rw-r--r--words.c5201
140 files changed, 35791 insertions, 22541 deletions
diff --git a/Makefile b/Makefile
new file mode 100644
index 000000000000..976d00a7fa12
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,60 @@
+OBJECTS= dictionary.o system.o fileaccess.o float.o double.o prefix.o search.o softcore.o stack.o tools.o vm.o primitives.o bit.o lzuncompress.o unix.o utility.o hash.o callback.o word.o extras.o
+HEADERS= ficl.h ficlplatform/unix.h
+#
+# Flags for shared library
+#TARGET= -Dlinux # riscos MOTO_CPU32
+SHFLAGS = -fPIC
+CFLAGS= -O $(SHFLAGS) -Wall
+CPPFLAGS= $(TARGET) -I.
+CC = cc
+LIB = ar cr
+RANLIB = ranlib
+
+MAJOR = 4
+MINOR = 1.0
+
+ficl: main.o $(HEADERS) libficl.a
+ $(CC) $(CFLAGS) $(LDFLAGS) main.o -o ficl -L. -lficl -lm
+
+lib: libficl.so.$(MAJOR).$(MINOR)
+
+# static library build
+libficl.a: $(OBJECTS)
+ $(LIB) libficl.a $(OBJECTS)
+ $(RANLIB) libficl.a
+
+# shared library build
+libficl.so.$(MAJOR).$(MINOR): $(OBJECTS)
+ $(CC) $(LDFLAGS) -shared -Wl,-soname,libficl.so.$(MAJOR).$(MINOR) \
+ -o libficl.so.$(MAJOR).$(MINOR) $(OBJECTS)
+ ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so
+
+main: main.o ficl.h sysdep.h libficl.so.$(MAJOR).$(MINOR)
+ $(CC) $(CFLAGS) $(LDFLAGS) main.o -o main -L. -lficl -lm
+ ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so.$(MAJOR)
+
+# depend explicitly to help finding source files in another subdirectory,
+# and repeat commands since gmake doesn't understand otherwise
+ansi.o: ficlplatform/ansi.c $(HEADERS)
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
+unix.o: ficlplatform/unix.c $(HEADERS)
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+#
+# generic object code
+#
+.SUFFIXES: .cxx .cc .c .o
+
+.c.o:
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+.cxx.o:
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+.cc.o:
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
+#
+# generic cleanup code
+#
+clean:
+ rm -f *.o *.a libficl.* ficl
diff --git a/Makefile.ansi b/Makefile.ansi
new file mode 100644
index 000000000000..e510fcda2ca8
--- /dev/null
+++ b/Makefile.ansi
@@ -0,0 +1,56 @@
+OBJECTS= dictionary.o system.o fileaccess.o float.o double.o prefix.o search.o softcore.o stack.o tools.o vm.o primitives.o bit.o lzuncompress.o ansi.o utility.o hash.o callback.o word.o extras.o
+HEADERS= ficl.h ficlplatform/ansi.h
+#
+# Flags for shared library
+TARGET= -ansi -DFICL_ANSI # riscos MOTO_CPU32
+SHFLAGS = -fPIC
+CFLAGS= -O $(SHFLAGS)
+CPPFLAGS= $(TARGET) -I.
+CC = cc
+LIB = ar cr
+RANLIB = ranlib
+
+MAJOR = 4
+MINOR = 1.0
+
+ficl: main.o $(HEADERS) libficl.a
+ $(CC) main.o -o ficl -L. -lficl -lm
+
+lib: libficl.so.$(MAJOR).$(MINOR)
+
+# static library build
+libficl.a: $(OBJECTS)
+ $(LIB) libficl.a $(OBJECTS)
+ $(RANLIB) libficl.a
+
+# shared library build
+libficl.so.$(MAJOR).$(MINOR): $(OBJECTS)
+ $(CC) -shared -Wl,-soname,libficl.so.$(MAJOR).$(MINOR) \
+ -o libficl.so.$(MAJOR).$(MINOR) $(OBJECTS)
+ ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so
+
+main: main.o ficl.h sysdep.h libficl.so.$(MAJOR).$(MINOR)
+ $(CC) main.o -o main -L. -lficl -lm
+ ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so.$(MAJOR)
+
+ansi.o: ficlplatform/ansi.c $(HEADERS)
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ ficlplatform/ansi.c
+
+#
+# generic object code
+#
+.SUFFIXES: .cxx .cc .c .o
+
+.c.o:
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+.cxx.o:
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+.cc.o:
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
+#
+# generic cleanup code
+#
+clean:
+ rm -f *.o *.a libficl.*
diff --git a/Makefile.linux b/Makefile.linux
index 5dbca1012744..d447e7e88178 100644
--- a/Makefile.linux
+++ b/Makefile.linux
@@ -1,19 +1,20 @@
-OBJECTS= dict.o ficl.o fileaccess.o float.o math64.o prefix.o search.o softcore.o stack.o sysdep.o tools.o unix.o vm.o words.o
-HEADERS= ficl.h math64.h sysdep.h
+OBJECTS= dictionary.o system.o fileaccess.o float.o double.o prefix.o search.o softcore.o stack.o tools.o vm.o primitives.o bit.o lzuncompress.o unix.o utility.o hash.o callback.o word.o extras.o
+HEADERS= ficl.h ficlplatform/unix.h
#
# Flags for shared library
TARGET= -Dlinux # riscos MOTO_CPU32
SHFLAGS = -fPIC
-CFLAGS= -O -c $(SHFLAGS) $(TARGET)
-CC=gcc
+CFLAGS= -O $(SHFLAGS)
+CPPFLAGS= $(TARGET) -I.
+CC = cc
LIB = ar cr
RANLIB = ranlib
-MAJOR = 3
-MINOR = 0.1
+MAJOR = 4
+MINOR = 1.0
-ficl: testmain.o ficl.h sysdep.h libficl.a
- $(CC) testmain.o -o ficl -L. -lficl -lm
+ficl: main.o $(HEADERS) libficl.a
+ $(CC) main.o -o ficl -L. -lficl -lm
lib: libficl.so.$(MAJOR).$(MINOR)
@@ -28,23 +29,26 @@ libficl.so.$(MAJOR).$(MINOR): $(OBJECTS)
-o libficl.so.$(MAJOR).$(MINOR) $(OBJECTS)
ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so
-testmain: testmain.o ficl.h sysdep.h libficl.so.$(MAJOR).$(MINOR)
- $(CC) testmain.o -o testmain -L. -lficl -lm
+main: main.o ficl.h sysdep.h libficl.so.$(MAJOR).$(MINOR)
+ $(CC) main.o -o main -L. -lficl -lm
ln -sf libficl.so.$(MAJOR).$(MINOR) libficl.so.$(MAJOR)
+unix.o: ficlplatform/unix.c $(HEADERS)
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ ficlplatform/unix.c
+
#
# generic object code
#
.SUFFIXES: .cxx .cc .c .o
.c.o:
- $(CC) $(CFLAGS) -c $*.c
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
.cxx.o:
- $(CPP) $(CPFLAGS) -c $*.cxx
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
.cc.o:
- $(CPP) $(CPFLAGS) -c $*.cc
+ $(CPP) $(CXXFLAGS) $(CPPFLAGS) -c -o $@ $<
#
# generic cleanup code
#
diff --git a/ReadMe.txt b/ReadMe.txt
index 6985b807d248..4ea553d0217e 100644
--- a/ReadMe.txt
+++ b/ReadMe.txt
@@ -1,5 +1,5 @@
-FICL 3.03
-April 2002
+FICL 4.1.0
+October 2010
________
OVERVIEW
@@ -10,18 +10,22 @@ and development prototype language. Ficl stands for "Forth Inspired
Command Language".
For more information, please see the "doc" directory.
-For release notes, please see "doc/ficl_rel.html".
+For release notes, please see "doc/releases.html".
____________
INSTALLATION
Ficl builds out-of-the-box on the following platforms:
- * Linux: use "Makefile.linux".
- * RiscOS: use "Makefile.riscos".
+ * NetBSD, FreeBSD: use "Makefile".
+ * Linux: use "Makefile.linux", but it should work with
+ "Makefile" as well.
* Win32: use "ficl.dsw" / "ficl.dsp".
-To port to other platforms, be sure to examine "sysdep.h", and
-we suggest you start with the Linux makefile. (And please--feel
-free to submit your portability changes!)
+To port to other platforms, we suggest you start with the generic
+"Makefile" and the "unix.c" / "unix.h" platform-specific implementation
+files. (And please--feel free to submit your portability changes!)
+
+(Note: Ficl used to build under RiscOS, but we broke everything
+for the 4.0 release. Please fix it and send us the diffs!)
____________
FICL LICENSE
diff --git a/bit.c b/bit.c
new file mode 100644
index 000000000000..68907c0ed06e
--- /dev/null
+++ b/bit.c
@@ -0,0 +1,49 @@
+#include "ficl.h"
+
+int ficlBitGet(const unsigned char *bits, size_t index)
+ {
+ int byteIndex = index >> 3;
+ int bitIndex = index & 7;
+ unsigned char mask = (unsigned char)(128 >> bitIndex);
+
+ return ((mask & bits[byteIndex]) ? 1 : 0);
+ }
+
+
+
+void ficlBitSet(unsigned char *bits, size_t index, int value)
+ {
+ int byteIndex = index >> 3;
+ int bitIndex = index & 7;
+ unsigned char mask = (unsigned char)(128 >> bitIndex);
+
+ if (value)
+ bits[byteIndex] |= mask;
+ else
+ bits[byteIndex] &= ~mask;
+ }
+
+
+void ficlBitGetString(unsigned char *destination, const unsigned char *source, int offset, int count, int destAlignment)
+ {
+ int bit = destAlignment - count;
+ while (count--)
+ ficlBitSet(destination, bit++, ficlBitGet(source, offset++));
+ }
+
+
+/*
+** This will actually work correctly *regardless* of the local architecture.
+** --lch
+**/
+ficlUnsigned16 ficlNetworkUnsigned16(ficlUnsigned16 number)
+{
+ ficlUnsigned8 *pointer = (ficlUnsigned8 *)&number;
+ return (ficlUnsigned16)(((ficlUnsigned16)(pointer[0] << 8)) | (pointer[1]));
+}
+
+ficlUnsigned32 ficlNetworkUnsigned32(ficlUnsigned32 number)
+{
+ ficlUnsigned16 *pointer = (ficlUnsigned16 *)&number;
+ return ((ficlUnsigned32)(ficlNetworkUnsigned16(pointer[0]) << 16)) | ficlNetworkUnsigned16(pointer[1]);
+}
diff --git a/callback.c b/callback.c
new file mode 100644
index 000000000000..6d6d65c54904
--- /dev/null
+++ b/callback.c
@@ -0,0 +1,76 @@
+#include "ficl.h"
+
+
+extern ficlSystem *ficlSystemGlobal;
+
+/**************************************************************************
+ f i c l C a l l b a c k T e x t O u t
+** Feeds text to the vm's output callback
+**************************************************************************/
+void ficlCallbackTextOut(ficlCallback *callback, char *text)
+{
+ ficlOutputFunction textOut = NULL;
+
+ if (callback != NULL)
+ {
+ if (callback->textOut != NULL)
+ textOut = callback->textOut;
+ else if ((callback->system != NULL) && (callback != &(callback->system->callback)))
+ {
+ ficlCallbackTextOut(&(callback->system->callback), text);
+ return;
+ }
+ }
+
+ if ((textOut == NULL) && (ficlSystemGlobal != NULL))
+ {
+ callback = &(ficlSystemGlobal->callback);
+ textOut = callback->textOut;
+ }
+
+ if (textOut == NULL)
+ textOut = ficlCallbackDefaultTextOut;
+
+ (textOut)(callback, text);
+
+ return;
+}
+
+
+/**************************************************************************
+ f i c l C a l l b a c k E r r o r O u t
+** Feeds text to the vm's error output callback
+**************************************************************************/
+void ficlCallbackErrorOut(ficlCallback *callback, char *text)
+{
+ ficlOutputFunction errorOut = NULL;
+
+ if (callback != NULL)
+ {
+ if (callback->errorOut != NULL)
+ errorOut = callback->errorOut;
+ else if ((callback->system != NULL) && (callback != &(callback->system->callback)))
+ {
+ ficlCallbackErrorOut(&(callback->system->callback), text);
+ return;
+ }
+ }
+
+ if ((errorOut == NULL) && (ficlSystemGlobal != NULL))
+ {
+ callback = &(ficlSystemGlobal->callback);
+ errorOut = callback->errorOut;
+ }
+
+ if (errorOut == NULL)
+ {
+ ficlCallbackTextOut(callback, text);
+ return;
+ }
+
+ (errorOut)(callback, text);
+
+ return;
+}
+
+
diff --git a/compatibility.c b/compatibility.c
new file mode 100644
index 000000000000..6970e4a422af
--- /dev/null
+++ b/compatibility.c
@@ -0,0 +1,284 @@
+#define FICL_FORCE_COMPATIBILITY 1
+#include "ficl.h"
+
+
+FICL_PLATFORM_EXTERN ficlStack *stackCreate (unsigned cells) { return ficlStackCreate(NULL, "unknown", cells); }
+FICL_PLATFORM_EXTERN void stackDelete (ficlStack *stack) { ficlStackDestroy(stack); }
+FICL_PLATFORM_EXTERN int stackDepth (ficlStack *stack) { return ficlStackDepth(stack); }
+FICL_PLATFORM_EXTERN void stackDrop (ficlStack *stack, int n) { ficlStackDrop(stack, n); }
+FICL_PLATFORM_EXTERN ficlCell stackFetch (ficlStack *stack, int n) { return ficlStackFetch(stack, n); }
+FICL_PLATFORM_EXTERN ficlCell stackGetTop (ficlStack *stack) { return ficlStackFetch(stack, 0); }
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN void stackLink (ficlStack *stack, int cells) { ficlStackLink(stack, cells); }
+FICL_PLATFORM_EXTERN void stackUnlink (ficlStack *stack) { ficlStackUnlink(stack); }
+#endif /* FICL_WANT_LOCALS */
+FICL_PLATFORM_EXTERN void stackPick (ficlStack *stack, int n) { ficlStackPick(stack, n); }
+FICL_PLATFORM_EXTERN ficlCell stackPop (ficlStack *stack) { return ficlStackPop(stack); }
+FICL_PLATFORM_EXTERN void *stackPopPtr (ficlStack *stack) { return ficlStackPopPointer(stack); }
+FICL_PLATFORM_EXTERN ficlUnsigned stackPopUNS (ficlStack *stack) { return ficlStackPopUnsigned(stack); }
+FICL_PLATFORM_EXTERN ficlInteger stackPopINT (ficlStack *stack) { return ficlStackPopInteger(stack); }
+FICL_PLATFORM_EXTERN void stackPush (ficlStack *stack, ficlCell cell) { ficlStackPush(stack, cell); }
+FICL_PLATFORM_EXTERN void stackPushPtr (ficlStack *stack, void *pointer) { ficlStackPushPointer(stack, pointer); }
+FICL_PLATFORM_EXTERN void stackPushUNS (ficlStack *stack, ficlUnsigned u) { ficlStackPushUnsigned(stack, u); }
+FICL_PLATFORM_EXTERN void stackPushINT (ficlStack *stack, ficlInteger i) { ficlStackPushInteger(stack, i); }
+FICL_PLATFORM_EXTERN void stackReset (ficlStack *stack) { ficlStackReset(stack); }
+FICL_PLATFORM_EXTERN void stackRoll (ficlStack *stack, int n) { ficlStackRoll(stack, n); }
+FICL_PLATFORM_EXTERN void stackSetTop (ficlStack *stack, ficlCell cell) { ficlStackSetTop(stack, cell); }
+FICL_PLATFORM_EXTERN void stackStore (ficlStack *stack, int n, ficlCell cell) { ficlStackStore(stack, n, cell); }
+
+#if (FICL_WANT_FLOAT)
+FICL_PLATFORM_EXTERN ficlFloat stackPopFloat (ficlStack *stack) { return ficlStackPopFloat(stack); }
+FICL_PLATFORM_EXTERN void stackPushFloat(ficlStack *stack, ficlFloat f) { ficlStackPushFloat(stack, f); }
+#endif
+
+FICL_PLATFORM_EXTERN int wordIsImmediate(ficlWord *word) { return ficlWordIsImmediate(word); }
+FICL_PLATFORM_EXTERN int wordIsCompileOnly(ficlWord *word) { return ficlWordIsCompileOnly(word); }
+
+
+FICL_PLATFORM_EXTERN void vmBranchRelative(ficlVm *vm, int offset) { ficlVmBranchRelative(vm, offset); }
+FICL_PLATFORM_EXTERN ficlVm *vmCreate (ficlVm *vm, unsigned nPStack, unsigned nRStack) { return ficlVmCreate(vm, nPStack, nRStack); }
+FICL_PLATFORM_EXTERN void vmDelete (ficlVm *vm) { ficlVmDestroy(vm); }
+FICL_PLATFORM_EXTERN void vmExecute (ficlVm *vm, ficlWord *word) { ficlVmExecuteWord(vm, word); }
+FICL_PLATFORM_EXTERN ficlDictionary *vmGetDict (ficlVm *vm) { return ficlVmGetDictionary(vm); }
+FICL_PLATFORM_EXTERN char * vmGetString (ficlVm *vm, ficlCountedString *spDest, char delimiter) { return ficlVmGetString(vm, spDest, delimiter); }
+FICL_PLATFORM_EXTERN ficlString vmGetWord (ficlVm *vm) { return ficlVmGetWord(vm); }
+FICL_PLATFORM_EXTERN ficlString vmGetWord0 (ficlVm *vm) { return ficlVmGetWord0(vm); }
+FICL_PLATFORM_EXTERN int vmGetWordToPad (ficlVm *vm) { return ficlVmGetWordToPad(vm); }
+FICL_PLATFORM_EXTERN ficlString vmParseString (ficlVm *vm, char delimiter) { return ficlVmParseString(vm, delimiter); }
+FICL_PLATFORM_EXTERN ficlString vmParseStringEx(ficlVm *vm, char delimiter, char skipLeading) { return ficlVmParseStringEx(vm, delimiter, skipLeading); }
+FICL_PLATFORM_EXTERN ficlCell vmPop (ficlVm *vm) { return ficlVmPop(vm); }
+FICL_PLATFORM_EXTERN void vmPush (ficlVm *vm, ficlCell cell) { ficlVmPush(vm, cell); }
+FICL_PLATFORM_EXTERN void vmPopIP (ficlVm *vm) { ficlVmPopIP(vm); }
+FICL_PLATFORM_EXTERN void vmPushIP (ficlVm *vm, ficlIp newIP) { ficlVmPushIP(vm, newIP); }
+FICL_PLATFORM_EXTERN void vmQuit (ficlVm *vm) { ficlVmQuit(vm); }
+FICL_PLATFORM_EXTERN void vmReset (ficlVm *vm) { ficlVmReset(vm); }
+FICL_PLATFORM_EXTERN void vmThrow (ficlVm *vm, int except) { ficlVmThrow(vm, except); }
+FICL_PLATFORM_EXTERN void vmThrowErr (ficlVm *vm, char *fmt, ...) { va_list list; va_start(list, fmt); ficlVmThrowErrorVararg(vm, fmt, list); va_end(list); }
+
+FICL_PLATFORM_EXTERN void vmCheckStack(ficlVm *vm, int popCells, int pushCells) { FICL_IGNORE(vm); FICL_IGNORE(popCells); FICL_IGNORE(pushCells); FICL_STACK_CHECK(vm->dataStack, popCells, pushCells); }
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void vmCheckFStack(ficlVm *vm, int popCells, int pushCells) { FICL_IGNORE(vm); FICL_IGNORE(popCells); FICL_IGNORE(pushCells); FICL_STACK_CHECK(vm->floatStack, popCells, pushCells); }
+#endif
+
+FICL_PLATFORM_EXTERN void vmPushTib (ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib) { ficlVmPushTib(vm, text, nChars, pSaveTib); }
+FICL_PLATFORM_EXTERN void vmPopTib (ficlVm *vm, ficlTIB *pTib) { ficlVmPopTib(vm, pTib); }
+
+FICL_PLATFORM_EXTERN int isPowerOfTwo(ficlUnsigned u) { return ficlIsPowerOfTwo(u); }
+
+#if defined(_WIN32)
+/* #SHEESH
+** Why do Microsoft Meatballs insist on contaminating
+** my namespace with their string functions???
+*/
+#pragma warning(disable: 4273)
+#endif
+char *ltoa(ficlInteger value, char *string, int radix ) { return ficlLtoa(value, string, radix); }
+char *ultoa(ficlUnsigned value, char *string, int radix ) { return ficlUltoa(value, string, radix); }
+char *strrev( char *string ) { return ficlStringReverse(string); }
+#if defined(_WIN32)
+#pragma warning(default: 4273)
+#endif
+FICL_PLATFORM_EXTERN char digit_to_char(int value) { return ficlDigitToCharacter(value); }
+FICL_PLATFORM_EXTERN char *skipSpace(char *cp, char *end) { return ficlStringSkipSpace(cp, end); }
+FICL_PLATFORM_EXTERN char *caseFold(char *cp) { return ficlStringCaseFold(cp); }
+FICL_PLATFORM_EXTERN int strincmp(char *cp1, char *cp2, ficlUnsigned count) { return ficlStrincmp(cp1, cp2, count); }
+
+FICL_PLATFORM_EXTERN void hashForget (ficlHash *hash, void *where) { ficlHashForget(hash, where); }
+FICL_PLATFORM_EXTERN ficlUnsigned16 hashHashCode (ficlString string) { return ficlHashCode(string); }
+FICL_PLATFORM_EXTERN void hashInsertWord(ficlHash *hash, ficlWord *word) { ficlHashInsertWord(hash, word); }
+FICL_PLATFORM_EXTERN ficlWord *hashLookup (ficlHash *hash, ficlString string, ficlUnsigned16 hashCode) { return ficlHashLookup(hash, string, hashCode); }
+FICL_PLATFORM_EXTERN void hashReset (ficlHash *hash) { ficlHashReset(hash); }
+
+
+FICL_PLATFORM_EXTERN void *alignPtr(void *ptr) { return ficlAlignPointer(ptr); }
+FICL_PLATFORM_EXTERN void dictAbortDefinition(ficlDictionary *dictionary) { ficlDictionaryAbortDefinition(dictionary); }
+FICL_PLATFORM_EXTERN void dictAlign (ficlDictionary *dictionary) { ficlDictionaryAlign(dictionary); }
+FICL_PLATFORM_EXTERN int dictAllot (ficlDictionary *dictionary, int n) { ficlDictionaryAllot(dictionary, n); return 0; }
+FICL_PLATFORM_EXTERN int dictAllotCells (ficlDictionary *dictionary, int cells) { ficlDictionaryAllotCells(dictionary, cells); return 0; }
+FICL_PLATFORM_EXTERN void dictAppendCell (ficlDictionary *dictionary, ficlCell cell) { ficlDictionaryAppendCell(dictionary, cell); }
+FICL_PLATFORM_EXTERN void dictAppendChar (ficlDictionary *dictionary, char c) { ficlDictionaryAppendCharacter(dictionary, c); }
+FICL_PLATFORM_EXTERN ficlWord *dictAppendWord (ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags)
+ { return ficlDictionaryAppendPrimitive(dictionary, name, code, flags); }
+FICL_PLATFORM_EXTERN ficlWord *dictAppendWord2(ficlDictionary *dictionary,
+ ficlString name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags)
+ { return ficlDictionaryAppendWord(dictionary, name, code, flags); }
+FICL_PLATFORM_EXTERN void dictAppendUNS (ficlDictionary *dictionary, ficlUnsigned u) { ficlDictionaryAppendUnsigned(dictionary, u); }
+FICL_PLATFORM_EXTERN int dictCellsAvail (ficlDictionary *dictionary) { return ficlDictionaryCellsAvailable(dictionary); }
+FICL_PLATFORM_EXTERN int dictCellsUsed (ficlDictionary *dictionary) { return ficlDictionaryCellsUsed(dictionary); }
+FICL_PLATFORM_EXTERN void dictCheck (ficlDictionary *dictionary, ficlVm *vm, int n) { FICL_IGNORE(dictionary); FICL_IGNORE(vm); FICL_IGNORE(n); FICL_VM_DICTIONARY_CHECK(vm, dictionary, n); }
+FICL_PLATFORM_EXTERN ficlDictionary *dictCreate(unsigned cells) { return ficlDictionaryCreate(NULL, cells); }
+FICL_PLATFORM_EXTERN ficlDictionary *dictCreateHashed(unsigned cells, unsigned hash) { return ficlDictionaryCreateHashed(NULL, cells, hash); }
+FICL_PLATFORM_EXTERN ficlHash *dictCreateWordlist(ficlDictionary *dictionary, int nBuckets) { return ficlDictionaryCreateWordlist(dictionary, nBuckets); }
+FICL_PLATFORM_EXTERN void dictDelete (ficlDictionary *dictionary) { ficlDictionaryDestroy(dictionary); }
+FICL_PLATFORM_EXTERN void dictEmpty (ficlDictionary *dictionary, unsigned nHash) { ficlDictionaryEmpty(dictionary, nHash); }
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void ficlPrimitiveHashSummary(ficlVm *vm);
+FICL_PLATFORM_EXTERN void dictHashSummary(ficlVm *vm) { ficlPrimitiveHashSummary(vm); }
+#endif
+FICL_PLATFORM_EXTERN int dictIncludes (ficlDictionary *dictionary, void *p) { return ficlDictionaryIncludes(dictionary, p); }
+FICL_PLATFORM_EXTERN ficlWord *dictLookup (ficlDictionary *dictionary, ficlString name) { return ficlDictionaryLookup(dictionary, name); }
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN ficlWord *ficlLookupLoc (ficlSystem *system, ficlString name) { return ficlDictionaryLookup(ficlSystemGetLocals(system), name); }
+#endif
+FICL_PLATFORM_EXTERN void dictResetSearchOrder(ficlDictionary *dictionary) { ficlDictionaryResetSearchOrder(dictionary); }
+FICL_PLATFORM_EXTERN void dictSetFlags (ficlDictionary *dictionary, ficlUnsigned8 set, ficlUnsigned8 clear) { ficlDictionarySetFlags(dictionary, set); ficlDictionaryClearFlags(dictionary, clear); }
+FICL_PLATFORM_EXTERN void dictSetImmediate(ficlDictionary *dictionary) { ficlDictionarySetImmediate(dictionary); }
+FICL_PLATFORM_EXTERN void dictUnsmudge (ficlDictionary *dictionary) { ficlDictionaryUnsmudge(dictionary); }
+FICL_PLATFORM_EXTERN ficlCell *dictWhere (ficlDictionary *dictionary) { return ficlDictionaryWhere(dictionary); }
+
+FICL_PLATFORM_EXTERN int ficlAddParseStep(ficlSystem *system, ficlWord *word) { return ficlSystemAddParseStep(system, word); }
+FICL_PLATFORM_EXTERN void ficlAddPrecompiledParseStep(ficlSystem *system, char *name, ficlParseStep pStep) { ficlSystemAddPrimitiveParseStep(system, name, pStep); }
+FICL_PLATFORM_EXTERN void ficlPrimitiveParseStepList(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlListParseSteps(ficlVm *vm) { ficlPrimitiveParseStepList(vm); }
+
+FICL_PLATFORM_EXTERN void ficlTermSystem(ficlSystem *system) { ficlSystemDestroy(system); }
+FICL_PLATFORM_EXTERN int ficlEvaluate(ficlVm *vm, char *pText) { return ficlVmEvaluate(vm, pText); }
+FICL_PLATFORM_EXTERN int ficlExec (ficlVm *vm, char *pText) { ficlString s; FICL_STRING_SET_FROM_CSTRING(s, pText); return ficlVmExecuteString(vm, s); }
+FICL_PLATFORM_EXTERN int ficlExecC(ficlVm *vm, char *pText, ficlInteger nChars) { ficlString s; FICL_STRING_SET_POINTER(s, pText); FICL_STRING_SET_LENGTH(s, nChars); return ficlVmExecuteString(vm, s); }
+FICL_PLATFORM_EXTERN int ficlExecXT(ficlVm *vm, ficlWord *word) { return ficlVmExecuteXT(vm, word); }
+FICL_PLATFORM_EXTERN void ficlFreeVM(ficlVm *vm) { ficlVmDestroy(vm); }
+
+
+
+
+
+static void thunkTextOut(ficlCallback *callback, char *text)
+ {
+ ficlCompatibilityOutputFunction outputFunction;
+ if ((callback->vm != NULL) && (callback->vm->thunkedTextout != NULL))
+ outputFunction = callback->system->thunkedTextout;
+ else if (callback->system->thunkedTextout != NULL)
+ outputFunction = callback->system->thunkedTextout;
+ else
+ {
+ ficlCallbackDefaultTextOut(callback, text);
+ return;
+ }
+ ficlCompatibilityTextOutCallback(callback, text, outputFunction);
+ }
+
+
+FICL_PLATFORM_EXTERN void vmSetTextOut(ficlVm *vm, ficlCompatibilityOutputFunction textOut)
+ {
+ vm->thunkedTextout = textOut;
+ ficlVmSetTextOut(vm, thunkTextOut);
+ }
+
+FICL_PLATFORM_EXTERN void vmTextOut (ficlVm *vm, char *text, int fNewline)
+ {
+ ficlVmTextOut(vm, text);
+ if (fNewline)
+ ficlVmTextOut(vm, "\n");
+ }
+
+
+FICL_PLATFORM_EXTERN void ficlTextOut (ficlVm *vm, char *text, int fNewline)
+ {
+ vmTextOut(vm, text, fNewline);
+ }
+
+extern ficlSystem *ficlSystemGlobal;
+static defaultStackSize = FICL_DEFAULT_STACK_SIZE;
+FICL_PLATFORM_EXTERN int ficlSetStackSize(int nStackCells)
+{
+ if (defaultStackSize < nStackCells)
+ defaultStackSize = nStackCells;
+ if ((ficlSystemGlobal != NULL) && (ficlSystemGlobal->stackSize < nStackCells))
+ ficlSystemGlobal->stackSize = nStackCells;
+ return defaultStackSize;
+}
+
+
+FICL_PLATFORM_EXTERN ficlSystem *ficlInitSystemEx(ficlSystemInformation *fsi)
+{
+ ficlSystem *returnValue;
+ ficlCompatibilityOutputFunction thunkedTextout;
+ ficlSystemInformation clone;
+
+ memcpy(&clone, fsi, sizeof(clone));
+ thunkedTextout = (ficlCompatibilityOutputFunction)clone.textOut;
+ clone.textOut = clone.errorOut = thunkTextOut;
+
+ returnValue = ficlSystemCreate(&clone);
+ if (returnValue != NULL)
+ {
+ returnValue->thunkedTextout = thunkedTextout;
+ }
+ return returnValue;
+}
+
+
+FICL_PLATFORM_EXTERN ficlSystem *ficlInitSystem(int nDictCells)
+{
+ ficlSystemInformation fsi;
+ ficlSystemInformationInitialize(&fsi);
+ fsi.dictionarySize = nDictCells;
+ if (fsi.stackSize < defaultStackSize)
+ fsi.stackSize = defaultStackSize;
+ return ficlSystemCreate(&fsi);
+}
+
+
+
+
+FICL_PLATFORM_EXTERN ficlVm *ficlNewVM(ficlSystem *system)
+{
+ ficlVm *returnValue = ficlSystemCreateVm(system);
+ if (returnValue != NULL)
+ {
+ if ((returnValue->callback.textOut != NULL) && (returnValue->callback.textOut != thunkTextOut))
+ {
+ returnValue->thunkedTextout = (ficlCompatibilityOutputFunction)returnValue->callback.textOut;
+ returnValue->callback.textOut = thunkTextOut;
+ }
+ if ((returnValue->callback.errorOut != NULL) && (returnValue->callback.errorOut != thunkTextOut))
+ {
+ if (returnValue->thunkedTextout == NULL)
+ returnValue->thunkedTextout = (ficlCompatibilityOutputFunction)returnValue->callback.errorOut;
+ returnValue->callback.errorOut = thunkTextOut;
+ }
+ }
+ return returnValue;
+}
+
+
+
+FICL_PLATFORM_EXTERN ficlWord *ficlLookup(ficlSystem *system, char *name) { return ficlSystemLookup(system, name); }
+FICL_PLATFORM_EXTERN ficlDictionary *ficlGetDict(ficlSystem *system) { return ficlSystemGetDictionary(system); }
+FICL_PLATFORM_EXTERN ficlDictionary *ficlGetEnv (ficlSystem *system) { return ficlSystemGetEnvironment(system); }
+FICL_PLATFORM_EXTERN void ficlSetEnv (ficlSystem *system, char *name, ficlInteger value) { ficlDictionarySetConstant(ficlSystemGetDictionary(system), name, value); }
+FICL_PLATFORM_EXTERN void ficlSetEnvD(ficlSystem *system, char *name, ficlInteger high, ficlInteger low) { ficl2Unsigned value; FICL_2UNSIGNED_SET(low, high, value); ficlDictionarySet2Constant(ficlSystemGetDictionary(system), name, FICL_2UNSIGNED_TO_2INTEGER(value)); }
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN ficlDictionary *ficlGetLoc (ficlSystem *system) { return ficlSystemGetLocals(system); }
+#endif
+FICL_PLATFORM_EXTERN int ficlBuild(ficlSystem *system, char *name, ficlPrimitive code, char flags) { ficlDictionary *dictionary = ficlSystemGetDictionary(system); ficlDictionaryLock(dictionary, FICL_TRUE); ficlDictionaryAppendPrimitive(dictionary, name, code, flags); ficlDictionaryLock(dictionary, FICL_FALSE); return 0; }
+FICL_PLATFORM_EXTERN void ficlCompileCore(ficlSystem *system) { ficlSystemCompileCore(system); }
+FICL_PLATFORM_EXTERN void ficlCompilePrefix(ficlSystem *system) { ficlSystemCompilePrefix(system); }
+FICL_PLATFORM_EXTERN void ficlCompileSearch(ficlSystem *system) { ficlSystemCompileSearch(system); }
+FICL_PLATFORM_EXTERN void ficlCompileSoftCore(ficlSystem *system) { ficlSystemCompileSoftCore(system); }
+FICL_PLATFORM_EXTERN void ficlCompileTools(ficlSystem *system) { ficlSystemCompileTools(system); }
+FICL_PLATFORM_EXTERN void ficlCompileFile(ficlSystem *system) { ficlSystemCompileFile(system); }
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void ficlCompileFloat(ficlSystem *system) { ficlSystemCompileFloat(system); }
+FICL_PLATFORM_EXTERN int ficlParseFloatNumber( ficlVm *vm, ficlString string) { return ficlVmParseFloatNumber(vm, string); }
+#endif
+#if FICL_WANT_PLATFORM
+FICL_PLATFORM_EXTERN void ficlCompilePlatform(ficlSystem *system) { ficlSystemCompilePlatform(system); }
+#endif
+FICL_PLATFORM_EXTERN int ficlParsePrefix(ficlVm *vm, ficlString string) { return ficlVmParsePrefix(vm, string); }
+
+FICL_PLATFORM_EXTERN int ficlParseNumber(ficlVm *vm, ficlString string) { return ficlVmParseNumber(vm, string); }
+FICL_PLATFORM_EXTERN void ficlTick(ficlVm *vm) { ficlPrimitiveTick(vm); }
+FICL_PLATFORM_EXTERN void parseStepParen(ficlVm *vm) { ficlPrimitiveParseStepParen(vm); }
+
+FICL_PLATFORM_EXTERN int isAFiclWord(ficlDictionary *dictionary, ficlWord *word) { return ficlDictionaryIsAWord(dictionary, word); }
+
+
+FICL_PLATFORM_EXTERN void buildTestInterface(ficlSystem *system) { ficlSystemCompileExtras(system); }
+
+
diff --git a/contrib/xclasses/readme.txt b/contrib/xclasses/readme.txt
new file mode 100644
index 000000000000..1bd49d689a98
--- /dev/null
+++ b/contrib/xclasses/readme.txt
@@ -0,0 +1,111 @@
+XClasses is a simple IDL written in Python.
+You declare your classes, methods, and members as Python objects,
+and XClasses will generate the .c, .h, and .f files for you.
+Not only do the Forth classes line up with their C counterparts
+exactly, but all non-static methods (virtual and non-virtual)
+are *automatically* thunked. In other words, any method
+declared in XClasses and implemented in C can be called from
+the matching Ficl class, and the C method will be automatically
+called with the correct arguments. XClasses handles floating-point
+arguments too!
+
+Known limitations:
+ * All arguments must be one cell wide. (That means
+ only single-precision floats, too.)
+
+
+
+To use:
+ * Declare all your classes in a .py script
+ * Include "xclasses.h" everywhere you need your classes
+ * Include xclasses.cpp in your project somewhere
+ * Call
+ "xclasses.f" included
+ from your Ficl initialization script
+
+And you're mostly done!
+
+Simply including xclasses.f is not enough, though. You must
+explicitly instantiate your classes. This is to allow you a
+chance to add your own methods to the class. For a class
+named "myCallback", it would look like this:
+
+ declare-myCallback
+ end-myCallback
+
+You also have to define the "init" function for the class.
+Most of the time this will work fine:
+
+ declare-myCallback
+ use-default-init
+ end-myCallback
+
+
+The "default" init function calls the super class's init
+function, then sets all data members to 0. If this isn't
+what you want, roll your own. The init function takes
+the usual 2-cell "this" pointer as its argument:
+
+ declare-myCallback
+ : init ( 2:this ) ...
+ ;
+ end-myCallback
+
+For a do-nothing init function, you'll want this:
+
+ declare-myCallback
+ : init 2drop ;
+ end-myCallback
+
+
+Here's a random example from the simple game I'm working on:
+
+-----------------------------------------------------------------
+skinStream = xMethod("stream", "void").setVirtual(1)
+gjeSkin.addMethod(skinStream)
+
+##
+## gjeTexture
+##
+##
+gjeTexture = xClass("gjeTexture")
+gjeTexture.setParent(gjeSkin)
+gjeTexture.addMethod(skinStream)
+gjeTexture.addMethod(xMethod("clear", "void"))
+gjeTexture.addMember(xVariable("texture", "LPDIRECT3DTEXTURE8"))
+gjeTexture.addMember(xVariable("name", "char *"))
+gjeTexture.addMember(xVariable("variation", "int"))
+gjeTexture.addMember(xVariable("material", "D3DMATERIAL8 *"))
+
+-----------------------------------------------------------------
+
+I sure hope that's enough to get you started.
+
+
+
+Random notes:
+* XClasses doesn't deal well with struct-packing issues. It assumes
+ pretty much everything will be 4-byte aligned. This can bite you
+ if you add a 64-bit int... the C compiler may align it for you,
+ and XClasses won't know about it. (This could be fixed in a future
+ release... are you volunteering?) For now, it's best to declare
+ your classes such that 64-bit ints are naturally 8-byte aligned.
+
+* If you don't want to have to declare each class in turn,
+ you can add something like this to the end of your Python script:
+-----
+def declare(name):
+ xAddFiclFooter("\t\"" + name + ".constant\" \" sfind swap drop 0= [if] declare-" + name + " use-default-init end-" + name + " [endif] \" evaluate")
+
+
+xAddFiclFooter(": xclassesDeclare")
+for c in classes:
+ declare(c.name)
+xAddFiclFooter("\t;")
+-----
+ and then call "xclassesDeclare" from your Ficl script just after
+ including "xclasses.f".
+
+
+--lch
+larry@hastings.org
diff --git a/contrib/xclasses/xclasses.py b/contrib/xclasses/xclasses.py
new file mode 100644
index 000000000000..eaf449b19a27
--- /dev/null
+++ b/contrib/xclasses/xclasses.py
@@ -0,0 +1,870 @@
+import copy
+import string
+import sys
+import time
+import types
+
+
+def capitalize(s):
+ return string.upper(s[0]) + s[1:]
+
+def fprint(f, s):
+ print >> f, s
+
+
+def fprintHeader(f, comment = "//"):
+ fprint(f, comment)
+ fprint(f, comment + " Generated by xclasses.py at " + time.strftime("%Y/%m/%d %H:%M:%S"))
+ fprint(f, comment)
+ fprint(f, comment)
+ fprint(f, "")
+
+def fprintFooter(f, comment = "//"):
+ fprint(f, "")
+ fprint(f, "")
+ fprint(f, comment + " end of file")
+ fprint(f, "")
+
+multicallCallTypeFunction = 0
+multicallCallTypeMethod = 1
+multicallCallTypeVirtualMethod = 2
+
+multicallReturnTypeVoid = 0
+multicallReturnTypeInteger = 16
+multicallReturnTypeCstring = 32
+multicallReturnTypeFloat = 48
+
+multicallExplicitVtable = 512
+
+
+ficlVmName = "ficlVm"
+
+h_headers = []
+def xAddHHeader(line):
+ h_headers.append(line)
+
+h_footers = []
+def xAddHFooter(line):
+ h_footers.append(line)
+
+ficl_headers = []
+def xAddFiclHeader(line):
+ ficl_headers.append(line)
+
+ficl_footers = []
+def xAddFiclFooter(line):
+ ficl_footers.append(line)
+
+c_headers = []
+def xAddCHeader(line):
+ c_headers.append(line)
+
+c_footers = []
+def xAddCFooter(line):
+ c_footers.append(line)
+
+
+classes = []
+
+class xVariable:
+ def __init__(self, name, typeCPP = None, cells = None, count = None, defaultValue = None, cstring = None):
+ self.comments = []
+ self.setName(name)
+ self.setCells(cells)
+ self.setCount(count)
+ self.setDefaultValue(defaultValue)
+ self.setCString(cstring)
+ self.setTypeCPP(typeCPP)
+
+ def setName(self, name):
+ self.name = name
+ return self
+
+ def setTypeCPP(self, typeCPP):
+ self.typeCPP = typeCPP
+ if (typeCPP == "char *"):
+ self.setCString(1)
+ return self
+
+ def setCells(self, cells):
+ if cells == None:
+ self.cells = 1
+ else:
+ self.cells = cells
+ return self
+
+ def setCString(self, cstring):
+ self.cstring = cstring
+ return self
+
+ def isCString(self):
+ return self.cstring
+
+ def getTotalSize(self):
+ return self.cells * self.count
+
+ def setCount(self, count):
+ if type(count) != types.IntType:
+ count = 1
+ self.count = count
+ return self
+
+ def setDefaultValue(self, defaultValue):
+ if (defaultValue != None) and (type(defaultValue) != types.StringType):
+ defaultValue = str(defaultValue)
+ self.defaultValue = defaultValue
+ return self
+
+ def addComment(self, c):
+ self.comments.append(c)
+ return self
+
+ def isFloat(self):
+ return self.typeCPP == "float"
+
+ def stringCPP(self, wantDefaultValues=1):
+ if (type(self.typeCPP) != types.StringType):
+ sys.exit("didn't set a CPP type on variable " + self.name + "!")
+ output = self.typeCPP
+ if (self.typeCPP[-1] != "*") and (self.typeCPP[-1] != "&"):
+ output += " "
+ output += self.name
+ if self.count > 1:
+ output += "[" + str(self.count) + "]"
+ if self.count == 0:
+ output += "[]"
+ if wantDefaultValues and (self.defaultValue != None):
+ output += " = " + self.defaultValue
+ return output
+
+ def printH(self, f):
+ if len(self.comments):
+ for comment in self.comments:
+ fprint(f, "\t" + "// " + comment)
+ fprint(f, "\t" + self.stringCPP() + ";")
+
+ def printF(self, f):
+ totalCells = self.count * self.cells
+ if (totalCells <= 1):
+ typeF = "cell:"
+ else:
+ typeF = str(totalCells) + " cells:"
+ if len(self.comments):
+ for comment in self.comments:
+ fprint(f, "\t" + "// " + comment)
+ fprint(f, "\t" + "S\" " + typeF + " ." + self.name + " \" evaluate")
+
+
+class xMethod:
+ def __init__(self, name, returnType = None, virtual = None, static = None, body = None):
+ self.arguments = []
+ self.comments = []
+
+ self.setName(name)
+ self.setReturnType(returnType)
+ self.setVirtual(virtual)
+ self.setStatic(static)
+ self.setBody(body)
+ self.setThunkVariable(None)
+ self.vtableOffset = 0
+
+ def copy():
+ clone = xMethod(self.name, self.returnType, self.virtual, self.static)
+ clone.arguments = self.arguments
+ clone.comments = self.comments
+
+ def setName(self, name):
+ self.name = name
+ return self
+
+ def setReturnType(self, returnType):
+ if returnType.__class__ == xVariable:
+ self.returnType = returnType
+ elif type(returnType) == types.StringType:
+ self.returnType = xVariable("ignored", returnType)
+ else:
+ self.returnType = None
+ return self
+
+ def returnTypeIsVoid(self):
+ return(self.returnType == None) or (self.returnType.typeCPP == None) or (self.returnType.typeCPP == "") or (self.returnType.typeCPP == "void")
+
+ def setVirtual(self, virtual):
+ self.virtual = virtual
+ return self
+
+ def isVirtual(self):
+ return self.virtual > 0
+
+ def isPureVirtual(self):
+ return self.virtual > 1
+
+ def setStatic(self, static):
+ self.static = static
+ return self
+
+ def setThunkVariable(self, thunkVariable):
+ self.thunkVariable = thunkVariable
+ return self
+
+ def isStatic(self):
+ return self.static
+
+ # a constructor or a destructor
+ def isClassSpecial(self):
+ return (self.returnType == None) or (self.returnType.typeCPP == None) or (self.returnType.typeCPP == "")
+
+ def setBody(self, body):
+ self.body = body
+ return self
+
+ def addArgument(self, argument):
+ self.arguments.append(argument)
+ return self
+
+ def addComment(self, c):
+ self.comments.append(c)
+ return self
+
+ def prototype(self, isDefinition=None):
+ arguments = ""
+ for a in self.arguments:
+ if len(arguments):
+ arguments += ", "
+ arguments += a.stringCPP(not isDefinition)
+
+ if len(arguments) == 0:
+ arguments = "void"
+ className = ""
+ if (isDefinition):
+ className = self.memberOf.name + "::"
+ modifiers = ""
+ if self.virtual and (not isDefinition):
+ modifiers += "virtual "
+ if self.static and (not isDefinition):
+ modifiers += "static "
+ returnType = ""
+ name = self.name
+ if (name == "") or (name == "~"):
+ name += self.memberOf.name
+ if (self.returnType != None) and (len(self.returnType.typeCPP) > 0):
+ returnType = self.returnType.typeCPP + " "
+ return modifiers + returnType + className + name + "(" + arguments + ")"
+
+ def printH(self, f):
+ pureVirtual = ""
+ if (self.virtual > 1):
+ pureVirtual = " = 0"
+ suffix = ";"
+ modifiers = ""
+ if self.body != None:
+ modifiers = "inline "
+ suffix = " " + self.body
+ fprint(f, "\t" + modifiers + self.prototype() + pureVirtual + suffix)
+
+ def printF(self, f):
+ if not self.isVirtual():
+ return
+
+ if len(self.comments):
+ for comment in self.comments:
+ fprint(f, "\t" + "// " + comment)
+
+ flags = multicallReturnTypeInteger
+ if self.returnTypeIsVoid():
+ flags = multicallReturnTypeVoid
+ elif (self.returnType.isCString()):
+ flags = multicallReturnTypeCString
+ elif (self.returnType.typeCPP == "float"):
+ flags = multicallReturnTypeFloat
+ flags |= multicallCallTypeVirtualMethod
+ # move floating-point arguments from float stack
+ floatArgumentsBitfield = 0
+ cstringArgumentsBitfield = 0
+ argumentNumber = 0
+ cstrings = 0
+ name = self.name
+ if (self.memberOf.pureVirtual):
+ vtable = ""
+ else:
+ vtable = " drop [ " + self.memberOf.name + "-vtable literal ] "
+ flags |= multicallExplicitVtable
+ if (name == "") or (name == "~"):
+ name += self.memberOf.name
+ for a in self.arguments:
+ if a.isFloat():
+ floatArgumentsBitfield |= (1 << argumentNumber)
+ elif a.isCString():
+ cstringArgumentsBitfield |= (1 << argumentNumber)
+ cstrings += 1
+ argumentNumber += 1
+ fprint(f, "\tS\" : " + name + vtable + str(len(self.arguments) + cstrings) + " " + str(floatArgumentsBitfield) + " " + str(cstringArgumentsBitfield) + " " + str(self.vtableOffset) + " " + str(flags) + " multicall ; \" evaluate ")
+
+ def printCPP(self, f):
+ if (self.thunkVariable != None):
+ if (self.returnType != None) and (self.returnType.isCString()):
+ sys.exit("Can't thunk char * return values, sorry.")
+ fprint(f, "")
+ fprint(f, self.prototype(1))
+ fprint(f, "\t{")
+ fprint(f, "\tif (" + self.thunkVariable.name + " == NULL)")
+ if self.isClassSpecial() or self.returnTypeIsVoid():
+ fprint(f, "\t\treturn;")
+ elif (self.returnType.isFloat()):
+ fprint(f, "\t\treturn 0.0f;")
+ else:
+ fprint(f, "\t\treturn (" + self.returnType.typeCPP + ")0;")
+ fprint(f, "")
+
+ ficlVmName = self.memberOf.getFiclVmName()
+
+ ## output stack-checking code! how cool is that? --lch
+ dataStackPush = 2 # why 2? we always push this and ficlClass.
+ dataStackPop = 0
+ floatStackPush = 0
+ floatStackPop = 0
+
+ for a in self.arguments:
+ if (a.isCString()):
+ dataStackPush = dataStackPush + 2
+ elif (a.isFloat()):
+ floatStackPush = floatStackPush + 1
+ else:
+ dataStackPush = dataStackPush + 1
+
+ if (not self.returnTypeIsVoid()):
+ if (self.returnType.isFloat()):
+ floatStackPop = 1
+ else:
+ dataStackPop = 1
+
+ if (dataStackPush or dataStackPop or floatStackPush or floatStackPop):
+ fprint(f, "#ifdef _DEBUG")
+ if (dataStackPush or dataStackPop):
+ fprint(f, "\tficlStackCheck(" + ficlVmName + "->dataStack, " + str(dataStackPush) + ", " + str(dataStackPop) + ");")
+ if (floatStackPush or floatStackPop):
+ fprint(f, "\tficlStackCheck(" + ficlVmName + "->floatStack, " + str(floatStackPush) + ", " + str(floatStackPop) + ");")
+ fprint(f, "#endif // _DEBUG")
+
+ reversedArguments = copy.copy(self.arguments)
+ reversedArguments.reverse()
+
+ for a in reversedArguments:
+ if (a.isCString()):
+ fprint(f, "\tficlStackPushPointer(" + ficlVmName + "->dataStack, " + a.name + ");")
+ fprint(f, "\tficlStackPushInteger(" + ficlVmName + "->dataStack, strlen(" + a.name + "));")
+ elif (a.isFloat()):
+ fprint(f, "\tficlStackPushFloat(" + ficlVmName + "->floatStack, " + a.name + ");")
+ else:
+ fprint(f, "\tficlStackPushInteger(" + ficlVmName + "->dataStack, (int)" + a.name + ");")
+ fprint(f, "\tficlStackPushPointer(" + ficlVmName + "->dataStack, this);")
+ fprint(f, "\tficlStackPushPointer(" + ficlVmName + "->dataStack, ficlClass);")
+ fprint(f, "\tficlVmExecuteXT(" + ficlVmName + ", " + self.thunkVariable.name + ");")
+ if (not self.returnTypeIsVoid()):
+ if (self.returnType.isFloat()):
+ fprint(f, "\treturn ficlStackPopFloat(" + ficlVmName + "->floatStack);")
+ else:
+ fprint(f, "\treturn (" + self.returnType.typeCPP + ")ficlStackPopInteger(" + ficlVmName + "->dataStack);")
+ fprint(f, "\t}")
+ fprint(f, "")
+
+ # don't do virtual functions
+ if self.isVirtual() or self.isClassSpecial():
+ return
+
+ name = self.name
+ if (name == "") or (name == "~"):
+ name += self.memberOf.name
+
+ fprint(f, "// " + self.memberOf.name + "::" + name)
+ if len(self.comments):
+ fprint(f, "\t" + "//")
+ for comment in self.comments:
+ fprint(f, "\t" + "// " + comment)
+
+ arguments = ""
+ for a in self.arguments:
+ if len(arguments):
+ arguments += ", "
+ arguments += a.stringCPP()
+
+ if len(arguments) == 0:
+ arguments = "void"
+ classModifier = self.memberOf.name + "::"
+ calltype = "FICL_MULTICALL_CALLTYPE_METHOD"
+ if self.isStatic():
+ classModifier = ""
+ calltype = "FICL_MULTICALL_CALLTYPE_FUNCTION"
+ returnString = "FICL_MULTICALL_RETURNTYPE_INTEGER"
+ if self.returnTypeIsVoid():
+ returnString = "FICL_MULTICALL_RETURNTYPE_VOID"
+ elif (self.returnType.typeCPP == "float"):
+ returnString = "FICL_MULTICALL_RETURNTYPE_FLOAT"
+ elif (self.returnType.isCString()):
+ returnString = "FICL_MULTICALL_RETURNTYPE_CSTRING"
+
+ # set bits in argumentFlags
+ floatArgumentsBitfield = 0
+ cstringArgumentsBitfield = 0
+ argumentNumber = 0
+ cstrings = 0
+ for a in self.arguments:
+ if a.isFloat():
+ floatArgumentsBitfield |= (1 << argumentNumber)
+ elif a.isCString():
+ cstringArgumentsBitfield |= (1 << argumentNumber)
+ cstrings += 1
+ argumentNumber += 1
+
+ uniqueSuffix = "_" + self.memberOf.name + "_" + name
+ # constructor is blank!
+ if (self.name == ""):
+ uniqueSuffix = "_" + self.memberOf.name + "_constructor"
+ # destructor is just a squiggle!
+ elif (self.name == "~"):
+ uniqueSuffix = "_" + self.memberOf.name + "_destructor"
+ printingHash = {}
+ printingHash["classname"] = "xMethod" + uniqueSuffix
+ printingHash["variablename"] = "instance" + uniqueSuffix
+ printingHash["address"] = self.returnType.typeCPP + " (" + classModifier + "*address)(" + arguments + ")"
+ printingHash["function"] = self.memberOf.name + "::" + name
+ printingHash["methodname"] = name
+ printingHash["argumentCount"] = str(len(self.arguments) + cstrings)
+ printingHash["floatArgumentsBitfield"] = str(floatArgumentsBitfield)
+ printingHash["cstringArgumentsBitfield"] = str(cstringArgumentsBitfield)
+ printingHash["flags"] = calltype + " | " + returnString
+ fprint(f, """
+struct %(classname)s
+ {
+ char *name;
+ int argumentCount;
+ int floatArgumentBitfield;
+ int cstringArgumentBitfield;
+ int flags;
+ %(address)s;
+ int zero;
+ };
+
+static %(classname)s %(variablename)s = { "%(methodname)s", %(argumentCount)s, %(floatArgumentsBitfield)s, %(cstringArgumentsBitfield)s, %(flags)s, %(function)s, 0 };
+""" % printingHash)
+
+
+
+
+
+class xClass:
+ def __init__(self, name):
+ self.members = []
+ self.methods = []
+ self.verbatim = []
+ self.name = name
+ self.superclass = None
+ self.superclassName = None
+ self.containsVtable = 0
+ self.vtableEntries = 0
+ self.firstMember = None
+ self.memberCellsTotal = 0
+ self.thunkedSubclass = None
+ self.pureVirtual = 0
+ self.setFiclVmName(None)
+ classes.append(self)
+
+
+ def subclassOf(self, superclass):
+ if type(superclass) == types.StringType:
+ self.superclassName = superclass
+ else:
+ self.superclass = superclass
+ self.superclassName = superclass.name
+ if superclass.containsVtable:
+ self.containsVtable = 2
+ self.pureVirtual = superclass.pureVirtual
+ self.vtableEntries = superclass.vtableEntries
+ else:
+ self.containsVtable = 0
+ return self
+
+ def thunkedSubclassOf(self, superclass):
+ self.subclassOf(superclass)
+ self.addMember(xVariable("ficlClass", "void *"))
+ for method in superclass.methods:
+ if not method.isClassSpecial() or method.isPureVirtual():
+ method = copy.deepcopy(method)
+ if method.isPureVirtual():
+ method.setVirtual(1)
+ self.addThunkedMethod(method)
+ self.constructor = xMethod("")
+ self.addMethod(self.constructor)
+ self.thunkedSubclass = 1
+ return self
+
+ def forwardDeclare(self):
+ xAddHHeader("class " + self.name + ";")
+
+
+ def addVerbatim(self, v):
+ self.verbatim.append(v)
+ return self
+
+ def addMember(self, variable):
+ self.members.append(variable)
+ self.memberCellsTotal += variable.getTotalSize()
+ if (self.firstMember == None):
+ self.firstMember = variable
+ return self
+
+ def removeMember(self, variable):
+ self.members.remove(variable)
+ self.memberCellsTotal -= variable.getTotalSize()
+ if (self.firstMember == variable):
+ self.firstMember = self.members[0]
+ return self
+
+ def addMemberArray(self, array):
+ map(self.addMember, copy.deepcopy(array))
+
+
+ def findPreviousInstanceOfVirtualMethod(self, name):
+ for method in self.methods:
+ if method.name == name:
+ return method
+ if (self.superclass != None) and (type(self.superclass) != types.StringType):
+ return self.superclass.findPreviousInstanceOfVirtualMethod(name)
+ return None
+
+ def setFiclVmName(self, name):
+ self.ficlVmName = name
+ return self
+
+ def getFiclVmName(self):
+ if self.ficlVmName != None:
+ return self.ficlVmName
+
+ global ficlVmName
+ return ficlVmName
+
+ def addMethod(self, method):
+ method.memberOf = self
+ if method.virtual:
+ previousInstance = self.findPreviousInstanceOfVirtualMethod(method.name)
+ if (previousInstance != None):
+ method.vtableOffset = previousInstance.vtableOffset
+ if previousInstance.isPureVirtual() and (not method.isPureVirtual()):
+ self.pureVirtual -= 1
+ else:
+ method.vtableOffset = self.vtableEntries
+ self.vtableEntries = self.vtableEntries + 1
+ if (not self.containsVtable):
+ self.containsVtable = 1
+ if method.isPureVirtual():
+ self.pureVirtual += 1
+ self.methods.append(method)
+ return self
+
+ def lookupMethod(self, methodName):
+ for m in self.methods:
+ if (m.name == methodName):
+ return m
+ return None
+
+ def removeMethod(self, method):
+ if (type(method) == types.StringType):
+ method = self.lookupMethod(method)
+ if method == None:
+ return None
+ method.memberOf = None
+ self.methods.remove(method)
+ if method.virtual:
+ previousInstance = self.findPreviousInstanceOfVirtualMethod(method.name)
+ if (previousInstance == None):
+ for m in self.methods:
+ if (m.vtableOffset >= method.vtableOffset):
+ m.vtableOffset = m.vtableOffset - 1
+ self.vtableEntries = self.vtableEntries - 1
+ if (self.vtableEntries == 0):
+ self.containsVtable = 0
+ if previousInstance.isPureVirtual() and (not method.isPureVirtual()):
+ self.pureVirtual += 1
+ else:
+ if method.isPureVirtual():
+ self.pureVirtual -= 1
+
+ if method.thunkVariable != None:
+ self.removeMember(method.thunkVariable)
+
+ return self
+
+ def addThunkedMethod(self, method):
+ method = copy.deepcopy(method)
+ self.addMethod(method)
+ name = capitalize(method.name)
+ if (method.isClassSpecial()):
+ if (name == ""):
+ name = "Constructor"
+ else:
+ name = "Destructor"
+ thunkVariable = xVariable("xt" + name, "ficlWord *")
+ self.addMember(thunkVariable)
+ method.setThunkVariable(thunkVariable)
+ return self
+
+ def addNoopConstructor(self):
+ self.addVerbatim(self.name + "() { }")
+ return self
+
+ def addConstructor(self, virtual = 0):
+ method = xMethod("")
+ method.setVirtual(virtual)
+ self.addMethod(method)
+ return method
+
+ def addDestructor(self, virtual = 0):
+ method = xMethod("~")
+ method.setVirtual(virtual)
+ self.addMethod(method)
+ return method
+
+ def addMemberWithAccessors(self, variable, writeBodiesToo = 1):
+ self.addMember(variable)
+ capitalizedName = capitalize(variable.name)
+
+ m = xMethod("set" + capitalizedName, "void").addArgument(variable)
+ if writeBodiesToo:
+ m.setBody("\t{ this->" + variable.name + " = " + variable.name + "; }")
+ self.addMethod(m)
+
+ m = xMethod("get" + capitalizedName, variable.typeCPP)
+ if writeBodiesToo:
+ m.setBody("\t{ return this->" + variable.name + "; }")
+ self.addMethod(m)
+
+ def addMethodArray(self, array):
+ map(self.addMethod, copy.deepcopy(array))
+
+ def addThunkedMethodArray(self, array):
+ map(self.addThunkedMethod, copy.deepcopy(array))
+
+ def printHforward(self, f):
+ fprint(f, "class " + self.name + ";")
+
+ def printH(self, f):
+ if (self.thunkedSubclass):
+ body = "\n\t\t{\n"
+ for m in self.methods:
+ if m.thunkVariable != None:
+ body += "\t\t" + m.thunkVariable.name + " = NULL;\n"
+ body += "\t\t}\n"
+ self.constructor.setBody(body)
+ s = ""
+ if self.superclassName != None:
+ s = " : public " + self.superclassName
+ fprint(f, "class " + self.name + s)
+ fprint(f, "\t" + "{")
+ fprint(f, "\t" + "public:")
+ fprint(f, "")
+ for member in self.members:
+ member.printH(f)
+ fprint(f, "")
+ for method in self.methods:
+ method.printH(f)
+ for v in self.verbatim:
+ fprint(f, "\t" + v + "\n")
+ fprint(f, "\t" + "};\n\n")
+
+ def printF(self, f):
+ s = self.superclassName
+ if s == None:
+ s = "object"
+
+ fprint(f, "")
+ fprint(f, "//")
+ fprint(f, "// " + self.name)
+ fprint(f, "//")
+ fprint(f, ": declare-" + self.name)
+ fprint(f, "\t" + "S\" " + s + " subclass " + self.name + " \" evaluate")
+ fprint(f, "")
+ if self.containsVtable == 1:
+ fprint(f, "\t" + "S\" cell: .vtable\" evaluate")
+ for member in self.members:
+ member.printF(f)
+ fprint(f, "")
+ if (self.firstMember == None):
+ fprint(f, "\t" + "S\" : default-init 2drop ; \" evaluate // no members!")
+ else:
+ storeFiclClass = ""
+ if (self.thunkedSubclass != None):
+ storeFiclClass = "this this my=> .ficlClass ! drop "
+ setVtable = ""
+ if self.containsVtable and (not self.pureVirtual):
+ setVtable = self.name + "-vtable this my=> .vtable ! "
+ fprint(f, "\t" + "S\" : default-init { 2:this -- } this my=> super my=> init this my=> ." + self.firstMember.name + " " + str(self.memberCellsTotal) + " cells 0 fill " + setVtable + storeFiclClass + "; \" evaluate")
+ fprint(f, "\t// " + self.name + " methods:")
+ fprint(f, "\t" + self.name + "-declare-methods")
+ for method in self.methods:
+ method.printF(f)
+ fprint(f, "\t;")
+ fprint(f, "")
+ fprint(f, ": end-" + self.name)
+ fprint(f, "\t" + "S\" end-class \" evaluate")
+ fprint(f, "\t" + "S\" " + self.name + " 2constant " + self.name + ".constant \" evaluate")
+ fprint(f, "\t;")
+ fprint(f, "")
+
+ def printCPP(self, f):
+ fprint(f, "//")
+ fprint(f, "// " + self.name)
+ fprint(f, "//")
+ for method in self.methods:
+ method.printCPP(f)
+ fprint(f, "")
+ fprint(f, "// " + self.name + " final structure")
+ fprint(f, "static xMethod *" + self.name + "_methods[] =")
+ fprint(f, "\t" + "{")
+ for method in self.methods:
+ if (method.isVirtual() or method.isClassSpecial()):
+ continue
+ fprint(f, "\t" + "(xMethod *)(&instance_" + self.name + "_" + method.name + "),")
+ fprint(f, "\t" + "NULL")
+ fprint(f, "\t" + "};")
+ if self.containsVtable and (not self.pureVirtual):
+ fprint(f, "")
+ fprint(f, "// " + self.name + " instance, so we can get the vtable")
+ fprint(f, "static " + self.name + " " + self.name + "_instance;" )
+ fprint(f, "")
+
+
+
+def xclassesFooter():
+ f = open("xclasses.h", "wt")
+
+ fprintHeader(f)
+ fprint(f, "#ifndef __XCLASSES_H")
+ fprint(f, "#define __XCLASSES_H")
+ fprint(f, "")
+ fprint(f, "extern void xclassesDefineMethods(ficlVm *vm);")
+ fprint(f, "")
+ fprint(f, "enum xtype");
+ fprint(f, "\t{");
+ fprint(f, "\txtypeInvalid = 0,");
+ for c in classes:
+ fprint(f, "\txtype_" + c.name + ",");
+ fprint(f, "\txtypeLast,");
+ fprint(f, "\t};");
+ fprint(f, "");
+ for line in h_headers:
+ fprint(f, line)
+ fprint(f, "")
+ fprint(f, "")
+ for c in classes:
+ c.printH(f)
+ for line in h_footers:
+ fprint(f, line)
+ fprint(f, "")
+ fprint(f, "#endif // __XCLASSES_H")
+ fprintFooter(f)
+ f.close()
+
+
+ f = open("xclasses.f", "wt")
+ fprintHeader(f)
+ fprint(f, ": use-default-init S\" : init { 2:this } this my=> super my=> init this my=> default-init ; \" evaluate ;");
+ for line in ficl_headers:
+ fprint(f, line)
+ fprint(f, "")
+ for c in classes:
+ c.printF(f)
+ for line in ficl_footers:
+ fprint(f, line)
+ fprint(f, "")
+ fprintFooter(f)
+ f.close()
+
+
+ f = open("xclasses.cpp", "wt")
+ fprintHeader(f)
+
+ for line in c_headers:
+ fprint(f, line)
+ fprint(f, "")
+
+ fprint(f, "#include \"xclasses.h\"")
+ fprint(f, """
+
+struct xMethod
+ {
+ char *name;
+ int argumentCount;
+ int floatArgumentBitfield;
+ int cstringArgumentBitfield;
+ int flags;
+ void *address;
+ int zero;
+ };
+
+struct xClass
+ {
+ char *name;
+ xMethod **methods;
+ void **instance;
+ };
+
+""")
+
+ for c in classes:
+ c.printCPP(f)
+ fprint(f, """
+static xClass classes[] =
+ {
+""")
+ for c in classes:
+ vtableVariable = "NULL"
+ if c.containsVtable and (not c.pureVirtual):
+ vtableVariable = "(void **)&" + c.name + "_instance"
+ fprint(f, "\t" + "{ \"" + c.name + "\", " + c.name + "_methods, " + vtableVariable + " },")
+ fprint(f, """
+ { NULL, NULL }
+ };
+
+void xclassesDefineMethods(ficlVm *vm)
+ {
+ char buffer[1024];
+ xClass *c;
+ xMethod **m;
+
+ for (c = classes; c->name != NULL; c++)
+ {
+ sprintf(buffer, " : %s-declare-methods ", c->name);
+ ficlVmEvaluate(vm, buffer);
+ for (m = c->methods; *m != NULL; m++)
+ {
+ xMethod *method = *m;
+ /* why is this here? I dunno, but MSVC seems to be packing my struct. So if address is zero, the next dword has the address. --lch */
+ if (method->address == NULL)
+ method->address = (void *)method->zero;
+ sprintf(buffer, " S\\" : %s drop %d %d %d %d %d multicall ; \\" evaluate ",
+ method->name,
+ method->argumentCount,
+ method->floatArgumentBitfield,
+ method->cstringArgumentBitfield,
+ method->address,
+ method->flags
+ );
+ ficlVmEvaluate(vm, buffer);
+ }
+ ficlVmEvaluate(vm, " ; ");
+ if (c->instance != NULL)
+ {
+ sprintf(buffer, "%s-vtable", c->name);
+ ficlDictionarySetConstantPointer(ficlVmGetDictionary(vm), buffer, *(c->instance));
+ }
+ }
+ }
+""")
+ for line in c_footers:
+ fprint(f, line)
+ fprint(f, "")
+ fprintFooter(f)
+ f.close()
+
+
+
diff --git a/dict.c b/dict.c
deleted file mode 100644
index 5f61c301555b..000000000000
--- a/dict.c
+++ /dev/null
@@ -1,836 +0,0 @@
-/*******************************************************************
-** d i c t . c
-** Forth Inspired Command Language - dictionary methods
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 19 July 1997
-** $Id: dict.c,v 1.12 2001-10-28 10:59:22-08 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** This file implements the dictionary -- FICL's model of
-** memory management. All FICL words are stored in the
-** dictionary. A word is a named chunk of data with its
-** associated code. FICL treats all words the same, even
-** precompiled ones, so your words become first-class
-** extensions of the language. You can even define new
-** control structures.
-**
-** 29 jun 1998 (sadler) added variable sized hash table support
-*/
-/*
-** 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
-** 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 <stdlib.h>
-#include <stdio.h> /* sprintf */
-#include <string.h>
-#include <ctype.h>
-#include "ficl.h"
-
-static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si);
-
-/**************************************************************************
- d i c t A b o r t D e f i n i t i o n
-** Abort a definition in process: reclaim its memory and unlink it
-** from the dictionary list. Assumes that there is a smudged
-** definition in process...otherwise does nothing.
-** NOTE: this function is not smart enough to unlink a word that
-** has been successfully defined (ie linked into a hash). It
-** only works for defs in process. If the def has been unsmudged,
-** nothing happens.
-**************************************************************************/
-void dictAbortDefinition(FICL_DICT *pDict)
-{
- FICL_WORD *pFW;
- ficlLockDictionary(TRUE);
- pFW = pDict->smudge;
-
- if (pFW->flags & FW_SMUDGE)
- pDict->here = (CELL *)pFW->name;
-
- ficlLockDictionary(FALSE);
- return;
-}
-
-
-/**************************************************************************
- a l i g n P t r
-** Aligns the given pointer to FICL_ALIGN address units.
-** Returns the aligned pointer value.
-**************************************************************************/
-void *alignPtr(void *ptr)
-{
-#if FICL_ALIGN > 0
- char *cp;
- CELL c;
- cp = (char *)ptr + FICL_ALIGN_ADD;
- c.p = (void *)cp;
- c.u = c.u & (~FICL_ALIGN_ADD);
- ptr = (CELL *)c.p;
-#endif
- return ptr;
-}
-
-
-/**************************************************************************
- d i c t A l i g n
-** Align the dictionary's free space pointer
-**************************************************************************/
-void dictAlign(FICL_DICT *pDict)
-{
- pDict->here = alignPtr(pDict->here);
-}
-
-
-/**************************************************************************
- d i c t A l l o t
-** Allocate or remove n chars of dictionary space, with
-** checks for underrun and overrun
-**************************************************************************/
-int dictAllot(FICL_DICT *pDict, int n)
-{
- char *cp = (char *)pDict->here;
-#if FICL_ROBUST
- if (n > 0)
- {
- if ((unsigned)n <= dictCellsAvail(pDict) * sizeof (CELL))
- cp += n;
- else
- return 1; /* dict is full */
- }
- else
- {
- n = -n;
- if ((unsigned)n <= dictCellsUsed(pDict) * sizeof (CELL))
- cp -= n;
- else /* prevent underflow */
- cp -= dictCellsUsed(pDict) * sizeof (CELL);
- }
-#else
- cp += n;
-#endif
- pDict->here = PTRtoCELL cp;
- return 0;
-}
-
-
-/**************************************************************************
- d i c t A l l o t C e l l s
-** Reserve space for the requested number of cells in the
-** dictionary. If nCells < 0 , removes space from the dictionary.
-**************************************************************************/
-int dictAllotCells(FICL_DICT *pDict, int nCells)
-{
-#if FICL_ROBUST
- if (nCells > 0)
- {
- if (nCells <= dictCellsAvail(pDict))
- pDict->here += nCells;
- else
- return 1; /* dict is full */
- }
- else
- {
- nCells = -nCells;
- if (nCells <= dictCellsUsed(pDict))
- pDict->here -= nCells;
- else /* prevent underflow */
- pDict->here -= dictCellsUsed(pDict);
- }
-#else
- pDict->here += nCells;
-#endif
- return 0;
-}
-
-
-/**************************************************************************
- d i c t A p p e n d C e l l
-** Append the specified cell to the dictionary
-**************************************************************************/
-void dictAppendCell(FICL_DICT *pDict, CELL c)
-{
- *pDict->here++ = c;
- return;
-}
-
-
-/**************************************************************************
- d i c t A p p e n d C h a r
-** Append the specified char to the dictionary
-**************************************************************************/
-void dictAppendChar(FICL_DICT *pDict, char c)
-{
- char *cp = (char *)pDict->here;
- *cp++ = c;
- pDict->here = PTRtoCELL cp;
- return;
-}
-
-
-/**************************************************************************
- d i c t A p p e n d W o r d
-** Create a new word in the dictionary with the specified
-** name, code, and flags. Name must be NULL-terminated.
-**************************************************************************/
-FICL_WORD *dictAppendWord(FICL_DICT *pDict,
- char *name,
- FICL_CODE pCode,
- UNS8 flags)
-{
- STRINGINFO si;
- SI_SETLEN(si, strlen(name));
- SI_SETPTR(si, name);
- return dictAppendWord2(pDict, si, pCode, flags);
-}
-
-
-/**************************************************************************
- d i c t A p p e n d W o r d 2
-** Create a new word in the dictionary with the specified
-** STRINGINFO, code, and flags. Does not require a NULL-terminated
-** name.
-**************************************************************************/
-FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
- STRINGINFO si,
- FICL_CODE pCode,
- UNS8 flags)
-{
- FICL_COUNT len = (FICL_COUNT)SI_COUNT(si);
- char *pName;
- FICL_WORD *pFW;
-
- ficlLockDictionary(TRUE);
-
- /*
- ** NOTE: dictCopyName advances "here" as a side-effect.
- ** It must execute before pFW is initialized.
- */
- pName = dictCopyName(pDict, si);
- pFW = (FICL_WORD *)pDict->here;
- pDict->smudge = pFW;
- pFW->hash = hashHashCode(si);
- pFW->code = pCode;
- pFW->flags = (UNS8)(flags | FW_SMUDGE);
- pFW->nName = (char)len;
- pFW->name = pName;
- /*
- ** Point "here" to first cell of new word's param area...
- */
- pDict->here = pFW->param;
-
- if (!(flags & FW_SMUDGE))
- dictUnsmudge(pDict);
-
- ficlLockDictionary(FALSE);
- return pFW;
-}
-
-
-/**************************************************************************
- d i c t A p p e n d U N S
-** Append the specified FICL_UNS to the dictionary
-**************************************************************************/
-void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u)
-{
- *pDict->here++ = LVALUEtoCELL(u);
- return;
-}
-
-
-/**************************************************************************
- d i c t C e l l s A v a i l
-** Returns the number of empty cells left in the dictionary
-**************************************************************************/
-int dictCellsAvail(FICL_DICT *pDict)
-{
- return pDict->size - dictCellsUsed(pDict);
-}
-
-
-/**************************************************************************
- d i c t C e l l s U s e d
-** Returns the number of cells consumed in the dicionary
-**************************************************************************/
-int dictCellsUsed(FICL_DICT *pDict)
-{
- return pDict->here - pDict->dict;
-}
-
-
-/**************************************************************************
- d i c t C h e c k
-** Checks the dictionary for corruption and throws appropriate
-** errors.
-** Input: +n number of ADDRESS UNITS (not Cells) proposed to allot
-** -n number of ADDRESS UNITS proposed to de-allot
-** 0 just do a consistency check
-**************************************************************************/
-void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int n)
-{
- if ((n >= 0) && (dictCellsAvail(pDict) * (int)sizeof(CELL) < n))
- {
- vmThrowErr(pVM, "Error: dictionary full");
- }
-
- if ((n <= 0) && (dictCellsUsed(pDict) * (int)sizeof(CELL) < -n))
- {
- vmThrowErr(pVM, "Error: dictionary underflow");
- }
-
- if (pDict->nLists > FICL_DEFAULT_VOCS)
- {
- dictResetSearchOrder(pDict);
- vmThrowErr(pVM, "Error: search order overflow");
- }
- else if (pDict->nLists < 0)
- {
- dictResetSearchOrder(pDict);
- vmThrowErr(pVM, "Error: search order underflow");
- }
-
- return;
-}
-
-
-/**************************************************************************
- d i c t C o p y N a m e
-** Copy up to nFICLNAME characters of the name specified by si into
-** the dictionary starting at "here", then NULL-terminate the name,
-** point "here" to the next available byte, and return the address of
-** the beginning of the name. Used by dictAppendWord.
-** N O T E S :
-** 1. "here" is guaranteed to be aligned after this operation.
-** 2. If the string has zero length, align and return "here"
-**************************************************************************/
-static char *dictCopyName(FICL_DICT *pDict, STRINGINFO si)
-{
- char *oldCP = (char *)pDict->here;
- char *cp = oldCP;
- char *name = SI_PTR(si);
- int i = SI_COUNT(si);
-
- if (i == 0)
- {
- dictAlign(pDict);
- return (char *)pDict->here;
- }
-
- if (i > nFICLNAME)
- i = nFICLNAME;
-
- for (; i > 0; --i)
- {
- *cp++ = *name++;
- }
-
- *cp++ = '\0';
-
- pDict->here = PTRtoCELL cp;
- dictAlign(pDict);
- return oldCP;
-}
-
-
-/**************************************************************************
- d i c t C r e a t e
-** Create and initialize a dictionary with the specified number
-** of cells capacity, and no hashing (hash size == 1).
-**************************************************************************/
-FICL_DICT *dictCreate(unsigned nCells)
-{
- return dictCreateHashed(nCells, 1);
-}
-
-
-FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash)
-{
- FICL_DICT *pDict;
- size_t nAlloc;
-
- nAlloc = sizeof (FICL_DICT) + nCells * sizeof (CELL)
- + sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *);
-
- pDict = ficlMalloc(nAlloc);
- assert(pDict);
-
- pDict->size = nCells;
- dictEmpty(pDict, nHash);
- return pDict;
-}
-
-
-/**************************************************************************
- d i c t C r e a t e W o r d l i s t
-** Create and initialize an anonymous wordlist
-**************************************************************************/
-FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets)
-{
- FICL_HASH *pHash;
-
- dictAlign(dp);
- pHash = (FICL_HASH *)dp->here;
- dictAllot(dp, sizeof (FICL_HASH)
- + (nBuckets-1) * sizeof (FICL_WORD *));
-
- pHash->size = nBuckets;
- hashReset(pHash);
- return pHash;
-}
-
-
-/**************************************************************************
- d i c t D e l e t e
-** Free all memory allocated for the given dictionary
-**************************************************************************/
-void dictDelete(FICL_DICT *pDict)
-{
- assert(pDict);
- ficlFree(pDict);
- return;
-}
-
-
-/**************************************************************************
- d i c t E m p t y
-** Empty the dictionary, reset its hash table, and reset its search order.
-** Clears and (re-)creates the hash table with the size specified by nHash.
-**************************************************************************/
-void dictEmpty(FICL_DICT *pDict, unsigned nHash)
-{
- FICL_HASH *pHash;
-
- pDict->here = pDict->dict;
-
- dictAlign(pDict);
- pHash = (FICL_HASH *)pDict->here;
- dictAllot(pDict,
- sizeof (FICL_HASH) + (nHash - 1) * sizeof (FICL_WORD *));
-
- pHash->size = nHash;
- hashReset(pHash);
-
- pDict->pForthWords = pHash;
- pDict->smudge = NULL;
- dictResetSearchOrder(pDict);
- return;
-}
-
-
-/**************************************************************************
- d i c t H a s h S u m m a r y
-** Calculate a figure of merit for the dictionary hash table based
-** on the average search depth for all the words in the dictionary,
-** assuming uniform distribution of target keys. The figure of merit
-** is the ratio of the total search depth for all keys in the table
-** versus a theoretical optimum that would be achieved if the keys
-** were distributed into the table as evenly as possible.
-** The figure would be worse if the hash table used an open
-** 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);
- FICL_HASH *pFHash;
- FICL_WORD **pHash;
- unsigned size;
- FICL_WORD *pFW;
- unsigned i;
- int nMax = 0;
- int nWords = 0;
- int nFilled;
- double avg = 0.0;
- double best;
- int nAvg, nRem, nDepth;
-
- dictCheck(dp, pVM, 0);
-
- pFHash = dp->pSearch[dp->nLists - 1];
- pHash = pFHash->table;
- size = pFHash->size;
- nFilled = size;
-
- for (i = 0; i < size; i++)
- {
- int n = 0;
- pFW = pHash[i];
-
- while (pFW)
- {
- ++n;
- ++nWords;
- pFW = pFW->link;
- }
-
- avg += (double)(n * (n+1)) / 2.0;
-
- if (n > nMax)
- nMax = n;
- if (n == 0)
- --nFilled;
- }
-
- /* Calc actual avg search depth for this hash */
- avg = avg / nWords;
-
- /* Calc best possible performance with this size hash */
- nAvg = nWords / size;
- nRem = nWords % size;
- nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
- best = (double)nDepth/nWords;
-
- sprintf(pVM->pad,
- "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%",
- size,
- (double)nFilled * 100.0 / size, nMax,
- avg,
- best,
- 100.0 * best / avg);
-
- ficlTextOut(pVM, pVM->pad, 1);
-
- return;
-}
-#endif
-
-/**************************************************************************
- d i c t I n c l u d e s
-** Returns TRUE iff the given pointer is within the address range of
-** the dictionary.
-**************************************************************************/
-int dictIncludes(FICL_DICT *pDict, void *p)
-{
- return ((p >= (void *) &pDict->dict)
- && (p < (void *)(&pDict->dict + pDict->size))
- );
-}
-
-
-/**************************************************************************
- d i c t L o o k u p
-** Find the FICL_WORD that matches the given name and length.
-** If found, returns the word's address. Otherwise returns NULL.
-** Uses the search order list to search multiple wordlists.
-**************************************************************************/
-FICL_WORD *dictLookup(FICL_DICT *pDict, STRINGINFO si)
-{
- FICL_WORD *pFW = NULL;
- FICL_HASH *pHash;
- int i;
- UNS16 hashCode = hashHashCode(si);
-
- assert(pDict);
-
- ficlLockDictionary(1);
-
- for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
- {
- pHash = pDict->pSearch[i];
- pFW = hashLookup(pHash, si, hashCode);
- }
-
- ficlLockDictionary(0);
- return pFW;
-}
-
-
-/**************************************************************************
- f i c l L o o k u p L o c
-** Same as dictLookup, but looks in system locals dictionary first...
-** Assumes locals dictionary has only one wordlist...
-**************************************************************************/
-#if FICL_WANT_LOCALS
-FICL_WORD *ficlLookupLoc(FICL_SYSTEM *pSys, STRINGINFO si)
-{
- FICL_WORD *pFW = NULL;
- FICL_DICT *pDict = pSys->dp;
- FICL_HASH *pHash = ficlGetLoc(pSys)->pForthWords;
- int i;
- UNS16 hashCode = hashHashCode(si);
-
- assert(pHash);
- assert(pDict);
-
- ficlLockDictionary(1);
- /*
- ** check the locals dict first...
- */
- pFW = hashLookup(pHash, si, hashCode);
-
- /*
- ** If no joy, (!pFW) --------------------------v
- ** iterate over the search list in the main dict
- */
- for (i = (int)pDict->nLists - 1; (i >= 0) && (!pFW); --i)
- {
- pHash = pDict->pSearch[i];
- pFW = hashLookup(pHash, si, hashCode);
- }
-
- ficlLockDictionary(0);
- return pFW;
-}
-#endif
-
-
-/**************************************************************************
- d i c t R e s e t S e a r c h O r d e r
-** Initialize the dictionary search order list to sane state
-**************************************************************************/
-void dictResetSearchOrder(FICL_DICT *pDict)
-{
- assert(pDict);
- pDict->pCompile = pDict->pForthWords;
- pDict->nLists = 1;
- pDict->pSearch[0] = pDict->pForthWords;
- return;
-}
-
-
-/**************************************************************************
- d i c t S e t F l a g s
-** Changes the flags field of the most recently defined word:
-** Set all bits that are ones in the set parameter, clear all bits
-** that are ones in the clr parameter. Clear wins in case the same bit
-** is set in both parameters.
-**************************************************************************/
-void dictSetFlags(FICL_DICT *pDict, UNS8 set, UNS8 clr)
-{
- assert(pDict->smudge);
- pDict->smudge->flags |= set;
- pDict->smudge->flags &= ~clr;
- return;
-}
-
-
-/**************************************************************************
- d i c t S e t I m m e d i a t e
-** Set the most recently defined word as IMMEDIATE
-**************************************************************************/
-void dictSetImmediate(FICL_DICT *pDict)
-{
- assert(pDict->smudge);
- pDict->smudge->flags |= FW_IMMEDIATE;
- return;
-}
-
-
-/**************************************************************************
- d i c t U n s m u d g e
-** Completes the definition of a word by linking it
-** into the main list
-**************************************************************************/
-void dictUnsmudge(FICL_DICT *pDict)
-{
- FICL_WORD *pFW = pDict->smudge;
- FICL_HASH *pHash = pDict->pCompile;
-
- assert(pHash);
- assert(pFW);
- /*
- ** :noname words never get linked into the list...
- */
- if (pFW->nName > 0)
- hashInsertWord(pHash, pFW);
- pFW->flags &= ~(FW_SMUDGE);
- return;
-}
-
-
-/**************************************************************************
- d i c t W h e r e
-** Returns the value of the HERE pointer -- the address
-** of the next free cell in the dictionary
-**************************************************************************/
-CELL *dictWhere(FICL_DICT *pDict)
-{
- return pDict->here;
-}
-
-
-/**************************************************************************
- h a s h F o r g e t
-** Unlink all words in the hash that have addresses greater than or
-** equal to the address supplied. Implementation factor for FORGET
-** and MARKER.
-**************************************************************************/
-void hashForget(FICL_HASH *pHash, void *where)
-{
- FICL_WORD *pWord;
- unsigned i;
-
- assert(pHash);
- assert(where);
-
- for (i = 0; i < pHash->size; i++)
- {
- pWord = pHash->table[i];
-
- while ((void *)pWord >= where)
- {
- pWord = pWord->link;
- }
-
- pHash->table[i] = pWord;
- }
-
- return;
-}
-
-
-/**************************************************************************
- h a s h H a s h C o d e
-**
-** Generate a 16 bit hashcode from a character string using a rolling
-** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds
-** the name before hashing it...
-** N O T E : If string has zero length, returns zero.
-**************************************************************************/
-UNS16 hashHashCode(STRINGINFO si)
-{
- /* hashPJW */
- UNS8 *cp;
- UNS16 code = (UNS16)si.count;
- UNS16 shift = 0;
-
- if (si.count == 0)
- return 0;
-
- /* changed to run without errors under Purify -- lch */
- for (cp = (UNS8 *)si.cp; si.count && *cp; cp++, si.count--)
- {
- code = (UNS16)((code << 4) + tolower(*cp));
- shift = (UNS16)(code & 0xf000);
- if (shift)
- {
- code ^= (UNS16)(shift >> 8);
- code ^= (UNS16)shift;
- }
- }
-
- return (UNS16)code;
-}
-
-
-
-
-/**************************************************************************
- h a s h I n s e r t W o r d
-** Put a word into the hash table using the word's hashcode as
-** an index (modulo the table size).
-**************************************************************************/
-void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW)
-{
- FICL_WORD **pList;
-
- assert(pHash);
- assert(pFW);
-
- if (pHash->size == 1)
- {
- pList = pHash->table;
- }
- else
- {
- pList = pHash->table + (pFW->hash % pHash->size);
- }
-
- pFW->link = *pList;
- *pList = pFW;
- return;
-}
-
-
-/**************************************************************************
- h a s h L o o k u p
-** Find a name in the hash table given the hashcode and text of the name.
-** Returns the address of the corresponding FICL_WORD if found,
-** otherwise NULL.
-** Note: outer loop on link field supports inheritance in wordlists.
-** It's not part of ANS Forth - ficl only. hashReset creates wordlists
-** with NULL link fields.
-**************************************************************************/
-FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode)
-{
- FICL_UNS nCmp = si.count;
- FICL_WORD *pFW;
- UNS16 hashIdx;
-
- if (nCmp > nFICLNAME)
- nCmp = nFICLNAME;
-
- for (; pHash != NULL; pHash = pHash->link)
- {
- if (pHash->size > 1)
- hashIdx = (UNS16)(hashCode % pHash->size);
- else /* avoid the modulo op for single threaded lists */
- hashIdx = 0;
-
- for (pFW = pHash->table[hashIdx]; pFW; pFW = pFW->link)
- {
- if ( (pFW->nName == si.count)
- && (!strincmp(si.cp, pFW->name, nCmp)) )
- return pFW;
-#if FICL_ROBUST
- assert(pFW != pFW->link);
-#endif
- }
- }
-
- return NULL;
-}
-
-
-/**************************************************************************
- h a s h R e s e t
-** Initialize a FICL_HASH to empty state.
-**************************************************************************/
-void hashReset(FICL_HASH *pHash)
-{
- unsigned i;
-
- assert(pHash);
-
- for (i = 0; i < pHash->size; i++)
- {
- pHash->table[i] = NULL;
- }
-
- pHash->link = NULL;
- pHash->name = NULL;
- return;
-}
-
-
diff --git a/dictionary.c b/dictionary.c
new file mode 100644
index 000000000000..9b4ddc3f3160
--- /dev/null
+++ b/dictionary.c
@@ -0,0 +1,851 @@
+/*******************************************************************
+** d i c t . c
+** Forth Inspired Command Language - dictionary methods
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+** $Id: dictionary.c,v 1.2 2010/09/12 15:14:52 asau Exp $
+*******************************************************************/
+/*
+** This file implements the dictionary -- Ficl's model of
+** memory management. All Ficl words are stored in the
+** dictionary. A word is a named chunk of data with its
+** associated code. Ficl treats all words the same, even
+** precompiled ones, so your words become first-class
+** extensions of the language. You can even define new
+** control structures.
+**
+** 29 jun 1998 (sadler) added variable sized hash table support
+*/
+/*
+** 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
+** 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 <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "ficl.h"
+
+#define FICL_SAFE_CALLBACK_FROM_SYSTEM(system) (((system) != NULL) ? &((system)->callback) : NULL)
+#define FICL_SAFE_SYSTEM_FROM_DICTIONARY(dictionary) (((dictionary) != NULL) ? (dictionary)->system : NULL)
+#define FICL_DICTIONARY_ASSERT(dictionary, expression) FICL_SYSTEM_ASSERT(FICL_SAFE_SYSTEM_FROM_DICTIONARY(dictionary), expression)
+
+/**************************************************************************
+ d i c t A b o r t D e f i n i t i o n
+** Abort a definition in process: reclaim its memory and unlink it
+** from the dictionary list. Assumes that there is a smudged
+** definition in process...otherwise does nothing.
+** NOTE: this function is not smart enough to unlink a word that
+** has been successfully defined (ie linked into a hash). It
+** only works for defs in process. If the def has been unsmudged,
+** nothing happens.
+**************************************************************************/
+void ficlDictionaryAbortDefinition(ficlDictionary *dictionary)
+{
+ ficlWord *word;
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ word = dictionary->smudge;
+
+ if (word->flags & FICL_WORD_SMUDGED)
+ dictionary->here = (ficlCell *)word->name;
+
+ ficlDictionaryLock(dictionary, FICL_FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t A l i g n
+** Align the dictionary's free space pointer
+**************************************************************************/
+void ficlDictionaryAlign(ficlDictionary *dictionary)
+{
+ dictionary->here = ficlAlignPointer(dictionary->here);
+}
+
+
+/**************************************************************************
+ d i c t A l l o t
+** Allocate or remove n chars of dictionary space, with
+** checks for underrun and overrun
+**************************************************************************/
+void ficlDictionaryAllot(ficlDictionary *dictionary, int n)
+{
+ char *here = (char *)dictionary->here;
+ here += n;
+ dictionary->here = FICL_POINTER_TO_CELL(here);
+}
+
+
+/**************************************************************************
+ d i c t A l l o t C e l l s
+** Reserve space for the requested number of ficlCells in the
+** dictionary. If nficlCells < 0 , removes space from the dictionary.
+**************************************************************************/
+void ficlDictionaryAllotCells(ficlDictionary *dictionary, int nficlCells)
+{
+ dictionary->here += nficlCells;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d C e l l
+** Append the specified ficlCell to the dictionary
+**************************************************************************/
+void ficlDictionaryAppendCell(ficlDictionary *dictionary, ficlCell c)
+{
+ *dictionary->here++ = c;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d C h a r
+** Append the specified char to the dictionary
+**************************************************************************/
+void ficlDictionaryAppendCharacter(ficlDictionary *dictionary, char c)
+{
+ char *here = (char *)dictionary->here;
+ *here++ = c;
+ dictionary->here = FICL_POINTER_TO_CELL(here);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d U N S
+** Append the specified ficlUnsigned to the dictionary
+**************************************************************************/
+void ficlDictionaryAppendUnsigned(ficlDictionary *dictionary, ficlUnsigned u)
+{
+ *dictionary->here++ = FICL_LVALUE_TO_CELL(u);
+ return;
+}
+
+
+void *ficlDictionaryAppendData(ficlDictionary *dictionary, void *data, ficlInteger length)
+{
+ char *here = (char *)dictionary->here;
+ char *oldHere = here;
+ char *from = (char *)data;
+
+ if (length == 0)
+ {
+ ficlDictionaryAlign(dictionary);
+ return (char *)dictionary->here;
+ }
+
+ while (length)
+ {
+ *here++ = *from++;
+ length--;
+ }
+
+ *here++ = '\0';
+
+ dictionary->here = FICL_POINTER_TO_CELL(here);
+ ficlDictionaryAlign(dictionary);
+ return oldHere;
+}
+
+
+/**************************************************************************
+ d i c t C o p y N a m e
+** Copy up to FICL_NAME_LENGTH characters of the name specified by s into
+** the dictionary starting at "here", then NULL-terminate the name,
+** point "here" to the next available byte, and return the address of
+** the beginning of the name. Used by dictAppendWord.
+** N O T E S :
+** 1. "here" is guaranteed to be aligned after this operation.
+** 2. If the string has zero length, align and return "here"
+**************************************************************************/
+char *ficlDictionaryAppendString(ficlDictionary *dictionary, ficlString s)
+{
+ void *data = FICL_STRING_GET_POINTER(s);
+ ficlInteger length = FICL_STRING_GET_LENGTH(s);
+
+ if (length > FICL_NAME_LENGTH)
+ length = FICL_NAME_LENGTH;
+
+ return ficlDictionaryAppendData(dictionary, data, length);
+}
+
+
+ficlWord *ficlDictionaryAppendConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value)
+{
+ ficlWord *word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)instruction, FICL_WORD_DEFAULT);
+ if (word != NULL)
+ ficlDictionaryAppendUnsigned(dictionary, value);
+ return word;
+}
+
+
+ficlWord *ficlDictionaryAppend2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value)
+{
+ ficlWord *word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)instruction, FICL_WORD_DEFAULT);
+ if (word != NULL)
+ {
+ ficlDictionaryAppendUnsigned(dictionary, FICL_2UNSIGNED_GET_HIGH(value));
+ ficlDictionaryAppendUnsigned(dictionary, FICL_2UNSIGNED_GET_LOW(value));
+ }
+ return word;
+}
+
+
+
+ficlWord *ficlDictionaryAppendConstant(ficlDictionary *dictionary, char *name, ficlInteger value)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppendConstantInstruction(dictionary, s, ficlInstructionConstantParen, value);
+}
+
+
+
+ficlWord *ficlDictionaryAppend2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppend2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, value);
+}
+
+
+
+ficlWord *ficlDictionarySetConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value)
+{
+ ficlWord *word = ficlDictionaryLookup(dictionary, name);
+
+ if (word == NULL)
+ {
+ word = ficlDictionaryAppendConstantInstruction(dictionary, name, instruction, value);
+ }
+ else
+ {
+ word->code = (ficlPrimitive)instruction;
+ word->param[0] = FICL_LVALUE_TO_CELL(value);
+ }
+ return word;
+}
+
+ficlWord *ficlDictionarySetConstant(ficlDictionary *dictionary, char *name, ficlInteger value)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySetConstantInstruction(dictionary, s, ficlInstructionConstantParen, value);
+}
+
+ficlWord *ficlDictionarySet2ConstantInstruction(ficlDictionary *dictionary, ficlString s, ficlInstruction instruction, ficl2Integer value)
+{
+ ficlWord *word;
+ word = ficlDictionaryLookup(dictionary, s);
+
+ /* only reuse the existing word if we're sure it has space for a 2constant */
+ if ((word != NULL) &&
+ ((((ficlInstruction)word->code) == ficlInstruction2ConstantParen)
+#if FICL_WANT_FLOAT
+ ||
+ (((ficlInstruction)word->code) == ficlInstructionF2ConstantParen)
+#endif /* FICL_WANT_FLOAT */
+ )
+ )
+ {
+ word->code = (ficlPrimitive)instruction;
+ word->param[0].u = FICL_2UNSIGNED_GET_HIGH(value);
+ word->param[1].u = FICL_2UNSIGNED_GET_LOW(value);
+ }
+ else
+ {
+ word = ficlDictionaryAppend2ConstantInstruction(dictionary, s, instruction, value);
+ }
+
+ return word;
+}
+
+
+ficlWord *ficlDictionarySet2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, value);
+}
+
+
+ficlWord *ficlDictionarySetConstantString(ficlDictionary *dictionary, char *name, char *value)
+{
+ ficlString s;
+ ficl2Integer valueAs2Integer;
+ FICL_2INTEGER_SET(strlen(value), (intptr_t)value, valueAs2Integer);
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+
+ return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, valueAs2Integer);
+}
+
+
+
+/**************************************************************************
+ d i c t A p p e n d W o r d
+** Create a new word in the dictionary with the specified
+** ficlString, code, and flags. Does not require a NULL-terminated
+** name.
+**************************************************************************/
+ficlWord *ficlDictionaryAppendWord(ficlDictionary *dictionary,
+ ficlString name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags)
+{
+ ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
+ char *nameCopy;
+ ficlWord *word;
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+
+ /*
+ ** NOTE: ficlDictionaryAppendString advances "here" as a side-effect.
+ ** It must execute before word is initialized.
+ */
+ nameCopy = ficlDictionaryAppendString(dictionary, name);
+ word = (ficlWord *)dictionary->here;
+ dictionary->smudge = word;
+ word->hash = ficlHashCode(name);
+ word->code = code;
+ word->semiParen = ficlInstructionSemiParen;
+ word->flags = (ficlUnsigned8)(flags | FICL_WORD_SMUDGED);
+ word->length = length;
+ word->name = nameCopy;
+ /*
+ ** Point "here" to first ficlCell of new word's param area...
+ */
+ dictionary->here = word->param;
+
+ if (!(flags & FICL_WORD_SMUDGED))
+ ficlDictionaryUnsmudge(dictionary);
+
+ ficlDictionaryLock(dictionary, FICL_FALSE);
+ return word;
+}
+
+
+/**************************************************************************
+ d i c t A p p e n d W o r d
+** Create a new word in the dictionary with the specified
+** name, code, and flags. Name must be NULL-terminated.
+**************************************************************************/
+ficlWord *ficlDictionaryAppendPrimitive(ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppendWord(dictionary, s, code, flags);
+}
+
+
+ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags)
+{
+ ficlString s;
+ ficlWord *word;
+
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ word = ficlDictionaryLookup(dictionary, s);
+
+ if (word == NULL)
+ {
+ word = ficlDictionaryAppendPrimitive(dictionary, name, code, flags);
+ }
+ else
+ {
+ word->code = (ficlPrimitive)code;
+ word->flags = flags;
+ }
+ return word;
+}
+
+
+ficlWord *ficlDictionaryAppendInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags)
+{
+ return ficlDictionaryAppendPrimitive(dictionary, name, (ficlPrimitive)i, (ficlUnsigned8)(FICL_WORD_INSTRUCTION | flags));
+}
+
+ficlWord *ficlDictionarySetInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags)
+{
+ return ficlDictionarySetPrimitive(dictionary, name, (ficlPrimitive)i, (ficlUnsigned8)(FICL_WORD_INSTRUCTION | flags));
+}
+
+
+/**************************************************************************
+ d i c t C e l l s A v a i l
+** Returns the number of empty ficlCells left in the dictionary
+**************************************************************************/
+int ficlDictionaryCellsAvailable(ficlDictionary *dictionary)
+{
+ return dictionary->size - ficlDictionaryCellsUsed(dictionary);
+}
+
+
+/**************************************************************************
+ d i c t C e l l s U s e d
+** Returns the number of ficlCells consumed in the dicionary
+**************************************************************************/
+int ficlDictionaryCellsUsed(ficlDictionary *dictionary)
+{
+ return dictionary->here - dictionary->base;
+}
+
+
+
+/**************************************************************************
+ d i c t C r e a t e
+** Create and initialize a dictionary with the specified number
+** of ficlCells capacity, and no hashing (hash size == 1).
+**************************************************************************/
+ficlDictionary *ficlDictionaryCreate(ficlSystem *system, unsigned size)
+{
+ return ficlDictionaryCreateHashed(system, size, 1);
+}
+
+
+ficlDictionary *ficlDictionaryCreateHashed(ficlSystem *system, unsigned size, unsigned bucketCount)
+{
+ ficlDictionary *dictionary;
+ size_t nAlloc;
+
+ nAlloc = sizeof(ficlDictionary) + (size * sizeof (ficlCell))
+ + sizeof(ficlHash) + (bucketCount - 1) * sizeof (ficlWord *);
+
+ dictionary = ficlMalloc(nAlloc);
+ FICL_SYSTEM_ASSERT(system, dictionary != NULL);
+
+ dictionary->size = size;
+ dictionary->system = system;
+
+ ficlDictionaryEmpty(dictionary, bucketCount);
+ return dictionary;
+}
+
+
+/**************************************************************************
+ d i c t C r e a t e W o r d l i s t
+** Create and initialize an anonymous wordlist
+**************************************************************************/
+ficlHash *ficlDictionaryCreateWordlist(ficlDictionary *dictionary, int bucketCount)
+{
+ ficlHash *hash;
+
+ ficlDictionaryAlign(dictionary);
+ hash = (ficlHash *)dictionary->here;
+ ficlDictionaryAllot(dictionary, sizeof (ficlHash)
+ + (bucketCount - 1) * sizeof (ficlWord *));
+
+ hash->size = bucketCount;
+ ficlHashReset(hash);
+ return hash;
+}
+
+
+/**************************************************************************
+ d i c t D e l e t e
+** Free all memory allocated for the given dictionary
+**************************************************************************/
+void ficlDictionaryDestroy(ficlDictionary *dictionary)
+{
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary != NULL);
+ ficlFree(dictionary);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t E m p t y
+** Empty the dictionary, reset its hash table, and reset its search order.
+** Clears and (re-)creates the hash table with the size specified by nHash.
+**************************************************************************/
+void ficlDictionaryEmpty(ficlDictionary *dictionary, unsigned bucketCount)
+{
+ ficlHash *hash;
+
+ dictionary->here = dictionary->base;
+
+ ficlDictionaryAlign(dictionary);
+ hash = (ficlHash *)dictionary->here;
+ ficlDictionaryAllot(dictionary,
+ sizeof (ficlHash) + (bucketCount - 1) * sizeof (ficlWord *));
+
+ hash->size = bucketCount;
+ ficlHashReset(hash);
+
+ dictionary->forthWordlist = hash;
+ dictionary->smudge = NULL;
+ ficlDictionaryResetSearchOrder(dictionary);
+ return;
+}
+
+
+/**************************************************************************
+** i s A F i c l W o r d
+** Vet a candidate pointer carefully to make sure
+** it's not some chunk o' inline data...
+** It has to have a name, and it has to look
+** like it's in the dictionary address range.
+** NOTE: this excludes :noname words!
+**************************************************************************/
+int ficlDictionaryIsAWord(ficlDictionary *dictionary, ficlWord *word)
+{
+ if ( (((ficlInstruction)word) > ficlInstructionInvalid)
+ && (((ficlInstruction)word) < ficlInstructionLast) )
+ return 1;
+
+ if (!ficlDictionaryIncludes(dictionary, word))
+ return 0;
+
+ if (!ficlDictionaryIncludes(dictionary, word->name))
+ return 0;
+
+ if ((word->link != NULL) && !ficlDictionaryIncludes(dictionary, word->link))
+ return 0;
+
+ if ((word->length <= 0) || (word->name[word->length] != '\0'))
+ return 0;
+
+ if (strlen(word->name) != word->length)
+ return 0;
+
+ return 1;
+}
+
+
+/**************************************************************************
+ f i n d E n c l o s i n g W o r d
+** Given a pointer to something, check to make sure it's an address in the
+** dictionary. If so, search backwards until we find something that looks
+** like a dictionary header. If successful, return the address of the
+** ficlWord found. Otherwise return NULL.
+** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
+**************************************************************************/
+#define nSEARCH_CELLS 100
+
+ficlWord *ficlDictionaryFindEnclosingWord(ficlDictionary *dictionary, ficlCell *cell)
+{
+ ficlWord *word;
+ int i;
+
+ if (!ficlDictionaryIncludes(dictionary, (void *)cell))
+ return NULL;
+
+ for (i = nSEARCH_CELLS; i > 0; --i, --cell)
+ {
+ word = (ficlWord *)(cell + 1 - (sizeof(ficlWord) / sizeof(ficlCell)));
+ if (ficlDictionaryIsAWord(dictionary, word))
+ return word;
+ }
+
+ return NULL;
+}
+
+
+/**************************************************************************
+ d i c t I n c l u d e s
+** Returns FICL_TRUE iff the given pointer is within the address range of
+** the dictionary.
+**************************************************************************/
+int ficlDictionaryIncludes(ficlDictionary *dictionary, void *p)
+{
+ return ((p >= (void *) &dictionary->base)
+ && (p < (void *)(&dictionary->base + dictionary->size)));
+}
+
+
+/**************************************************************************
+ d i c t L o o k u p
+** Find the ficlWord that matches the given name and length.
+** If found, returns the word's address. Otherwise returns NULL.
+** Uses the search order list to search multiple wordlists.
+**************************************************************************/
+ficlWord *ficlDictionaryLookup(ficlDictionary *dictionary, ficlString name)
+{
+ ficlWord *word = NULL;
+ ficlHash *hash;
+ int i;
+ ficlUnsigned16 hashCode = ficlHashCode(name);
+
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary != NULL);
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+
+ for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i)
+ {
+ hash = dictionary->wordlists[i];
+ word = ficlHashLookup(hash, name, hashCode);
+ }
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ return word;
+}
+
+
+/**************************************************************************
+ s e e
+** TOOLS ( "<spaces>name" -- )
+** Display a human-readable representation of the named word's definition.
+** The source of the representation (object-code decompilation, source
+** block, etc.) and the particular form of the display is implementation
+** defined.
+**************************************************************************/
+/*
+** ficlSeeColon (for proctologists only)
+** Walks a colon definition, decompiling
+** on the fly. Knows about primitive control structures.
+*/
+char *ficlDictionaryInstructionNames[] =
+{
+#define FICL_TOKEN(token, description) description,
+#define FICL_INSTRUCTION_TOKEN(token, description, flags) description,
+#include "ficltokens.h"
+#undef FICL_TOKEN
+#undef FICL_INSTRUCTION_TOKEN
+};
+
+void ficlDictionarySee(ficlDictionary *dictionary, ficlWord *word, ficlCallback *callback)
+{
+ char *trace;
+ ficlCell *cell = word->param;
+ ficlCell *param0 = cell;
+ char buffer[128];
+
+ for (; cell->i != ficlInstructionSemiParen; cell++)
+ {
+ ficlWord *word = (ficlWord *)(cell->p);
+
+ trace = buffer;
+ if ((void *)cell == (void *)buffer)
+ *trace++ = '>';
+ else
+ *trace++ = ' ';
+ trace += sprintf(trace, "%3d ", cell - param0);
+
+ if (ficlDictionaryIsAWord(dictionary, word))
+ {
+ ficlWordKind kind = ficlWordClassify(word);
+ ficlCell c, c2;
+
+ switch (kind)
+ {
+ case FICL_WORDKIND_INSTRUCTION:
+ sprintf(trace, "%s (instruction %ld)", ficlDictionaryInstructionNames[(long)word], (long)word);
+ break;
+ case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
+ c = *++cell;
+ sprintf(trace, "%s (instruction %ld), with argument %ld (%#lx)", ficlDictionaryInstructionNames[(long)word], (long)word, c.i, c.u);
+ break;
+ case FICL_WORDKIND_INSTRUCTION_WORD:
+ sprintf(trace, "%s :: executes %s (instruction word %ld)", word->name, ficlDictionaryInstructionNames[(long)word->code], (long)word->code);
+ break;
+ case FICL_WORDKIND_LITERAL:
+ c = *++cell;
+ if (ficlDictionaryIsAWord(dictionary, c.p) && (c.i >= ficlInstructionLast))
+ {
+ ficlWord *word = (ficlWord *)c.p;
+ sprintf(trace, "%.*s ( %#lx literal )",
+ word->length, word->name, c.u);
+ }
+ else
+ sprintf(trace, "literal %ld (%#lx)", c.i, c.u);
+ break;
+ case FICL_WORDKIND_2LITERAL:
+ c = *++cell;
+ c2 = *++cell;
+ sprintf(trace, "2literal %d %d (%#lx %#lx)", c2.i, c.i, c2.u, c.u);
+ break;
+#if FICL_WANT_FLOAT
+ case FICL_WORDKIND_FLITERAL:
+ c = *++cell;
+ sprintf(trace, "fliteral %f (%#lx)", c.f, c.u);
+ break;
+#endif /* FICL_WANT_FLOAT */
+ case FICL_WORDKIND_STRING_LITERAL:
+ {
+ ficlCountedString *counted = (ficlCountedString *)(void *)++cell;
+ cell = (ficlCell *)ficlAlignPointer(counted->text + counted->length + 1) - 1;
+ sprintf(trace, "s\" %.*s\"", counted->length, counted->text);
+ }
+ break;
+ case FICL_WORDKIND_CSTRING_LITERAL:
+ {
+ ficlCountedString *counted = (ficlCountedString *)(void *)++cell;
+ cell = (ficlCell *)ficlAlignPointer(counted->text + counted->length + 1) - 1;
+ sprintf(trace, "c\" %.*s\"", counted->length, counted->text);
+ }
+ break;
+ case FICL_WORDKIND_BRANCH0:
+ c = *++cell;
+ sprintf(trace, "branch0 %d", cell + c.i - param0);
+ break;
+ case FICL_WORDKIND_BRANCH:
+ c = *++cell;
+ sprintf(trace, "branch %d", cell + c.i - param0);
+ break;
+
+ case FICL_WORDKIND_QDO:
+ c = *++cell;
+ sprintf(trace, "?do (leave %d)", (ficlCell *)c.p - param0);
+ break;
+ case FICL_WORDKIND_DO:
+ c = *++cell;
+ sprintf(trace, "do (leave %d)", (ficlCell *)c.p - param0);
+ break;
+ case FICL_WORDKIND_LOOP:
+ c = *++cell;
+ sprintf(trace, "loop (branch %d)", cell + c.i - param0);
+ break;
+ case FICL_WORDKIND_OF:
+ c = *++cell;
+ sprintf(trace, "of (branch %d)", cell + c.i - param0);
+ break;
+ case FICL_WORDKIND_PLOOP:
+ c = *++cell;
+ sprintf(trace, "+loop (branch %d)", cell + c.i - param0);
+ break;
+ default:
+ sprintf(trace, "%.*s", word->length, word->name);
+ break;
+ }
+
+ }
+ else /* probably not a word - punt and print value */
+ {
+ sprintf(trace, "%ld ( %#lx )", cell->i, cell->u);
+ }
+
+ ficlCallbackTextOut(callback, buffer);
+ ficlCallbackTextOut(callback, "\n");
+ }
+
+ ficlCallbackTextOut(callback, ";\n");
+}
+
+/**************************************************************************
+ d i c t R e s e t S e a r c h O r d e r
+** Initialize the dictionary search order list to sane state
+**************************************************************************/
+void ficlDictionaryResetSearchOrder(ficlDictionary *dictionary)
+{
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary);
+ dictionary->compilationWordlist = dictionary->forthWordlist;
+ dictionary->wordlistCount = 1;
+ dictionary->wordlists[0] = dictionary->forthWordlist;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t S e t F l a g s
+** Changes the flags field of the most recently defined word:
+** Set all bits that are ones in the set parameter.
+**************************************************************************/
+void ficlDictionarySetFlags(ficlDictionary *dictionary, ficlUnsigned8 set)
+{
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
+ dictionary->smudge->flags |= set;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t C l e a r F l a g s
+** Changes the flags field of the most recently defined word:
+** Clear all bits that are ones in the clear parameter.
+**************************************************************************/
+void ficlDictionaryClearFlags(ficlDictionary *dictionary, ficlUnsigned8 clear)
+{
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
+ dictionary->smudge->flags &= ~clear;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t S e t I m m e d i a t e
+** Set the most recently defined word as IMMEDIATE
+**************************************************************************/
+void ficlDictionarySetImmediate(ficlDictionary *dictionary)
+{
+ FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
+ dictionary->smudge->flags |= FICL_WORD_IMMEDIATE;
+ return;
+}
+
+
+/**************************************************************************
+ d i c t U n s m u d g e
+** Completes the definition of a word by linking it
+** into the main list
+**************************************************************************/
+void ficlDictionaryUnsmudge(ficlDictionary *dictionary)
+{
+ ficlWord *word = dictionary->smudge;
+ ficlHash *hash = dictionary->compilationWordlist;
+
+ FICL_DICTIONARY_ASSERT(dictionary, hash);
+ FICL_DICTIONARY_ASSERT(dictionary, word);
+ /*
+ ** :noname words never get linked into the list...
+ */
+ if (word->length > 0)
+ ficlHashInsertWord(hash, word);
+ word->flags &= ~(FICL_WORD_SMUDGED);
+ return;
+}
+
+
+/**************************************************************************
+ d i c t W h e r e
+** Returns the value of the HERE pointer -- the address
+** of the next free ficlCell in the dictionary
+**************************************************************************/
+ficlCell *ficlDictionaryWhere(ficlDictionary *dictionary)
+{
+ return dictionary->here;
+}
+
+
diff --git a/doc/Logo.jpg b/doc/Logo.jpg
deleted file mode 100644
index c3332dbf65a1..000000000000
--- a/doc/Logo.jpg
+++ /dev/null
Binary files differ
diff --git a/doc/api.html b/doc/api.html
new file mode 100644
index 000000000000..379f0d33eca7
--- /dev/null
+++ b/doc/api.html
@@ -0,0 +1,401 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl api</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl api
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='QuickFiclProgrammingConceptsOverview'>
+Quick Ficl Programming Concepts Overview
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+A Ficl <i>dictionary</i> is equivalent to the FORTH "dictionary"; it is where words are stored.
+A single dictionary has a single <code>HERE</code> pointer.
+<p>
+
+A Ficl <i>system information</i> structure is used to change default values used
+in initializing a Ficl <i>system</i>.
+<p>
+
+A Ficl <i>system</i> contains a single <i>dictionary</i>, and one or more <i>virtual machines</i>.
+<p>
+
+A Ficl <i>stack</i> is equivalent to a FORTH "stack". Ficl has three stacks:
+<ul>
+
+<li>
+The <i>data</i> stack, where integer arguments are stored.
+
+<li>
+The <i>return</i> stack, where locals and return addresses for subroutine returns are stored.
+
+<li>
+The <i>float</i> stack, where floating-point arguments are stored. (This stack
+is only enabled when <code>FICL_WANT_FLOAT</code> is nonzero.)
+</ul>
+
+<p>
+
+A Ficl <i>virtual machine</i> (or <i>vm</i>) represents a single running instance of the Ficl interpreter.
+All virtual machines in a single Ficl system see the same dictionary.
+<p>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='QuickFiclProgrammingTutorial'>
+Quick Ficl Programming Tutorial
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Though Ficl's API offers a great deal of flexibility, most programs
+incorporating Ficl simply use it as follows:
+
+<ol>
+
+<li>
+Create a single <code>ficlSystem</code> using <code>ficlSystemCreate(NULL)</code>.
+
+<li>
+Add native functions as necessary with <code>ficlDictionarySetPrimitive()</code>.
+
+<li>
+Add constants as necessary with <code>ficlDictionarySetConstant()</code>.
+
+<li>
+Create one (or more) virtual machine(s) with <code>ficlSystemCreateVm()</code>.
+
+<li>
+Add one or more scripted functions with <code>ficlVmEvaluate()</code>.
+
+<li>
+Execute code in a Ficl virtual machine, usually with <code>ficlVmEvaluate()</code>,
+but perhaps with <code>ficlVmExecuteXT()</code>.
+
+<li>
+At shutdown, call <code>ficlSystemDestroy()</code> on the single Ficl system.
+
+</ol>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclApplicationProgrammingInterface'>
+Ficl Application Programming Interface
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+The following is a partial listing of functions that interface your
+system or program to Ficl. For a complete listing, see <code>ficl.h</code>
+(which is heavily commented). For a simple example, see <code>main.c</code>.
+<p>
+
+Note that as of Ficl 4, the API is internally consistent.
+<i>Every</i> external entry point starts with the word
+<code>ficl</code>, and the word after that also corresponds
+with the first argument. For instance, a word that operates
+on a <code>ficlSystem *</code> will be called <code>ficlSystem<i>Something</i>()</code>.
+
+
+
+
+<dl>
+
+<p><dt>
+<code>void ficlSystemInformationInitialize(ficlSystemInformation *fsi)</code>
+<dd>
+
+
+
+Resets a <code>ficlSystemInformation</code> structure to all zeros.
+(Actually implemented as a macro.) Use this to initialize a <code>ficlSystemInformation</code>
+structure before initializing its members and passing it
+into <code>ficlSystemCreate()</code> (below).
+
+<p><dt>
+<code>ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi)</code>
+<dd>
+
+
+
+Initializes Ficl's shared system data structures, and creates the
+dictionary allocating the specified number of cells from the heap
+(by a call to <code>ficlMalloc()</code>). If you pass in a <code>NULL</code>
+pointer, you will recieve a <code>ficlSystem</code> using the default
+sizes for the dictionary and stacks.
+
+
+<p><dt>
+<code>void ficlSystemDestroy(ficlSystem *system)</code>
+<dd>
+
+
+
+Reclaims memory allocated for the Ficl system including all
+dictionaries and all virtual machines created by
+<code>ficlSystemCreateVm()</code>. Note that this will <i>not</i>
+automatically free memory allocated by the FORTH memory allocation
+words (<code>ALLOCATE</code> and <code>RESIZE</code>).
+
+<p><dt>
+<code>ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary, char *name, ficlCode code, ficlUnsigned8 flags)</code>
+<dd>
+
+
+
+Adds a new word to the dictionary with the given
+name, code pointer, and flags. To add
+<p>
+
+The <code>flags</code> parameter is a bitfield. The valid
+flags are:<ul>
+
+<li>
+FICL_WORD_IMMEDIATE
+<li>
+FICL_WORD_COMPILE_ONLY
+<li>
+FICL_WORD_SMUDGED
+<li>
+FICL_WORD_OBJECT
+<li>
+FICL_WORD_INSTRUCTION
+
+</ul>
+
+For more information on these flags, see <code>ficl.h</code>.
+
+
+<p><dt>
+<code>ficlVm *ficlSystemCreateVm(ficlSystem *system)</code>
+<dd>
+
+
+
+Creates a new virtual machine in the specified system.
+
+
+<p><dt>
+<code>int ficlVmEvaluate(ficlVm *vm, char *text)</code>
+<dd>
+
+
+
+ the specified C string (zero-terminated) to the given
+virtual machine for evaluation. Returns various exception codes (VM_XXXX
+in ficl.h) to indicate the reason for returning. Normal exit
+condition is VM_OUTOFTEXT, indicating that the VM consumed the string
+successfully and is back for more. Calls to <code>ficlVmEvaluate()</code>
+can be nested, and
+the function itself is re-entrant, but note that a VM is
+static, so you have to take reasonable precautions (for example, use one
+VM per thread in a multithreaded system if you want multiple threads to
+be able to execute commands).
+
+
+<p><dt>
+<code>int ficlVmExecuteXT(ficlVm *vm, ficlWord *pFW)</code>
+<dd>
+
+
+
+Same as ficlExec, but takes a pointer to a ficlWord instead of a
+string. Executes the word and returns after it has finished. If
+executing the word results in an exception, this function will
+re-throw the same code if it is nested under another ficlExec family
+function, or return the exception code directly if not. This function
+is useful if you need to execute the same word repeatedly&mdash;you
+save the dictionary search and outer interpreter overhead.
+
+<p><dt>
+<code>void ficlFreeVM(ficlVm *vm)</code>
+<dd>
+
+
+
+Removes the VM in question from the system VM list and deletes
+the memory allocated to it. This is an optional call, since
+ficlTermSystem will do this cleanup for you. This function is
+handy if you're going to do a lot of dynamic creation of VMs.
+
+<p><dt>
+<code>ficlVm *ficlNewVM(ficlSystem *system)</code>
+<dd>
+
+
+
+Create, initialize, and return a VM from the heap using
+ficlMalloc. Links the VM into the system VM list for later reclamation
+by ficlTermSystem.
+
+<p><dt>
+<code>ficlWord *ficlSystemLookup(ficlSystem *system, char *name)</code>
+<dd>
+
+
+
+Returns the address of the specified word in the main dictionary.
+If no such word is found, it returns <code>NULL</code>.
+The address is also a valid execution token, and can be used in a call to <code>ficlVmExecuteXT()</code>.
+
+<p><dt>
+<code>ficlDictionary *ficlSystemGetDictionary(ficlSystem *system)<br>ficlDictionary *ficlVmGetDictionary(ficlVm *system)</code>
+<dd>
+
+
+
+Returns a pointer to the main system dictionary.
+
+
+<p><dt>
+<code>ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system)</code>
+<dd>
+
+
+
+Returns a pointer to the environment dictionary. This dictionary
+stores information that describes this implementation as required by the
+Standard.
+
+
+
+
+<p><dt>
+<code>ficlDictionary *ficlSystemGetLocals(ficlSystem *system)</code>
+<dd>
+
+
+
+Returns a pointer to the locals dictionary. This function is
+defined only if <code>FICL_WANT_LOCALS</code> is non-zero (see <code>ficl.h</code>).
+The locals dictionary is the symbol table for
+<a href="locals.html">local variables</a>.
+
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclCompile-TimeConstants'>
+Ficl Compile-Time Constants
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+There are a lot of preprocessor constants you can set at compile-time
+to modify Ficl's runtime behavior. Some are required, such as telling
+Ficl whether or not the local platform supports double-width integers
+(<code>FICL_PLATFORM_HAS_2INTEGER</code>);
+some are optional, such as telling Ficl whether or not to use the
+extended set of "prefixes" (<code>FICL_WANT_EXTENDED_PREFIXES</code>).
+<p>
+
+The best way to find out more about these constants is to read <code>ficl.h</code>
+yourself. The settings that turn on or off Ficl modules all start with
+<code>FICL_WANT</code>. The settings relating to functionality available
+on the current platform all start with <code>FICL_PLATFORM</code>.
+<p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='codeficllocalh/code'>
+<code>ficllocal.h</code>
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+One more note about constants. Ficl now ships with a standard place for
+you to tweak the Ficl compile-time preprocessor constants.
+It's a file called <code>ficllocal.h</code>, and we guarantee that it
+will always ship empty (or with only comments). We suggest that you
+put all your local changes there, rather than editing <code>ficl.h</code>
+or editing the makefile. That should make it much easier to integrate
+future Ficl releases into your product&mdash;all you need do is preserve
+your tweaked copy of <code>ficllocal.h</code> and replace the rest.
+
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/ficlddj.PDF b/doc/articles/ficlddj.pdf
index f058dbe4166a..f058dbe4166a 100644
--- a/doc/ficlddj.PDF
+++ b/doc/articles/ficlddj.pdf
Binary files differ
diff --git a/doc/jwsforml.PDF b/doc/articles/jwsforml.pdf
index b7c8a3d11250..b7c8a3d11250 100644
--- a/doc/jwsforml.PDF
+++ b/doc/articles/jwsforml.pdf
Binary files differ
diff --git a/doc/oo_in_c.html b/doc/articles/oo_in_c.html
index b483eb37b369..b483eb37b369 100644
--- a/doc/oo_in_c.html
+++ b/doc/articles/oo_in_c.html
diff --git a/doc/sigplan9906.doc b/doc/articles/sigplan9906.doc
index 1f4cea092e58..1f4cea092e58 100644
--- a/doc/sigplan9906.doc
+++ b/doc/articles/sigplan9906.doc
Binary files differ
diff --git a/doc/debugger.html b/doc/debugger.html
new file mode 100644
index 000000000000..31e948dd7686
--- /dev/null
+++ b/doc/debugger.html
@@ -0,0 +1,259 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl debugger</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl debugger
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+<p>Ficl includes a simple step debugger for colon definitions
+and <code>DOES></code> words.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='UsingTheFiclDebugger'>
+Using The Ficl Debugger
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+To debug a word, set up the stack with any parameters the word requires,
+then execute:
+<pre><b>DEBUG <i>your-word-name-here</i></b></pre>
+<p>
+
+If the word is unnamed, or all you have is an execution token,
+you can instead use <code>DEBUG-XT</code></b>
+<p>
+
+The debugger invokes <tt>SEE</tt> on the word which prints a crude source
+listing. It then stops at the first instruction of the definition. There are
+six (case insensitive) commands you can use from here onwards:
+
+<dl>
+
+<dt>
+<b>I</b> (step <b>I</b>n)
+<dd>If the next instruction is a colon defintion or does> word, steps into
+that word's code. If the word is a primitive, simply executes the word.
+
+<dt>
+<b>O</b> (step <b>O</b>ver)
+<dd>
+Executes the next instruction in its entirety.
+
+<dt>
+<b>G</b> (<b>G</b>o)
+<dd>
+Run the word to completion and exit the debugger.
+
+<dt>
+<b>L</b> (<b>L</b>ist)
+<dd>
+Lists the source code of the word presently being stepped.
+
+<dt>
+<b>Q</b> (<b>Q</b>uit)
+<dd>
+Abort the word and exit the debugger, clearing the stacks.
+
+<dt>
+<b>X</b> (e<b>X</b>ecute)
+<dd>
+Interpret the remainder of the line as Ficl words. Any change
+they make to the stacks will be preserved when the debugged word
+continues execution.
+Any errors will abort the debug session and reset the VM. Usage example:
+<pre>
+X DROP 3 \ change top argument on stack to 3
+</pre>
+
+</dl>
+
+
+Any other character will prints a list of available debugger commands.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='ThecodeON-STEP/codeEvent'>
+The <code>ON-STEP</code> Event
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+If there is a defined word named <code>ON-STEP</code> when the debugger starts, that
+word will be executed before every step. Its intended use is to display the stacks
+and any other VM state you find interesting. The default <code>ON-STEP</code> is:
+<p>
+
+<pre>
+: ON-STEP ." S: " .S-SIMPLE CR ;
+</pre>
+
+If you redefine <code>ON-STEP</code>, we recommend you ensure the word has no
+side-effects (for instance, adding or removing values from any stack).
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#d0d0d0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=3><b><i>
+<a name='OtherUsefulWordsForDebuggingAndcodeON-STEP/code'>
+Other Useful Words For Debugging And <code>ON-STEP</code>
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<dt>
+<code>.ENV ( -- )</code>
+<dd>
+Prints all environment settings non-destructively.
+
+<dt>
+<code>.S ( -- )</code>
+<dd>
+Prints the parameter stack non-destructively in a verbose format.
+
+<dt>
+<code>.S-SIMPLE ( -- )</code>
+<dd>
+Prints the parameter stack non-destructively in a simple single-line format.
+
+<dt>
+<code>F.S ( -- )</code>
+<dd>
+Prints the float stack non-destructively (only available if <code>FICL_WANT_FLOAT</code> is enabled).
+
+<dt>
+<code>R.S ( -- )</code>
+<dd>
+Prints a represention of the state of the return stack non-destructively.
+
+
+
+</dl>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='DebuggerInternals'>
+Debugger Internals
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<p>
+The debugger words are mostly located in source file <code>tools.c</code>. There are
+supporting words (<code>DEBUG</code> and <code>ON-STEP</code>) in <code>softcore.fr</code> as well.
+There are two main words that make the debugger go: <code>debug-xt</code> and <code>step-break</code>.
+<code>debug-xt</code> takes the execution token of a word to debug (as returned by <code>'</code> for example) ,
+checks to see if it is debuggable (not a primitive), sets a breakpoint at its
+first instruction, and runs <code>see</code> on it. To set a breakpoint,
+<code>debug-xt</code>
+replaces the instruction at the breakpoint with the execution token of <code>step-break</code>, and
+stores the original instruction and its address in a static breakpoint
+record. To clear the breakpoint, <code>step-break</code> simply replaces the original
+instruction and adjusts the target virtual machine's instruction pointer
+to run it.
+
+<p>
+
+<code>step-break</code> is responsible for processing debugger commands and setting
+breakpoints at subsequent instructions.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FutureEnhancements'>
+Future Enhancements
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<li>
+The debugger needs to exit automatically when it encounters the end of the word
+it was asked to debug. (Perhaps this could be a special kind of breakpoint?)
+
+<li>Add user-set breakpoints.
+
+<li>Add "step out" command.
+</dl>
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/dpans.html b/doc/dpans.html
new file mode 100644
index 000000000000..d6bc87acb8e3
--- /dev/null
+++ b/doc/dpans.html
@@ -0,0 +1,1037 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl standards compliance</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl standards compliance
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='ANSRequiredInformation'>
+ANS Required Information
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+The following documentation is necessary to comply for Ficl
+to comply with the DPANS94 standard. It describes what areas
+of the standard Ficl implements, what areas it does not, and
+how it behaves in areas undefined by the standard.
+
+<blockquote>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='ANSForthSystem'>
+ANS Forth System
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<b>
+
+Providing names from the Core Extensions word set
+<br>
+
+Providing names from the Double-Number word set
+<br>
+
+Providing the Exception word set
+<br>
+
+Providing the Exception Extensions word set
+<br>
+
+Providing the File-Access word set
+<br>
+
+Providing the File-Access Extensions word set
+<br>
+
+Providing names from the Floating-Point word set
+<br>
+
+Providing the Locals word set
+<br>
+
+Providing the Locals Extensions word set
+<br>
+
+Providing the Memory Allocation word set
+<br>
+
+Providing the Programming-Tools word set
+<br>
+
+Providing names from the Programming-Tools Extensions word set
+<br>
+
+Providing the Search-Order word set
+<br>
+
+Providing the Search-Order Extensions word set
+<br>
+
+Providing names from the String Extensions word set
+<br>
+
+</b>
+
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='Implementation-definedOptions'>
+Implementation-defined Options
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+The implementation-defined items in the following list represent
+characteristics and choices left to the discretion of the implementor,
+provided that the requirements of the Standard are met. A system shall
+document the values for, or behaviors of, each item.
+
+<dl>
+
+<dt><b>
+aligned address requirements (3.1.3.3 Addresses)
+</b><dd>
+
+
+
+System dependent. You can change the default address alignment by
+defining <code>FICL_ALIGN</code> on your compiler's command line,
+or in <code>platform.h</code>.
+The default value is set to 2 in <code>ficl.h</code>.
+This causes dictionary entries and <code>ALIGN</code> and
+<code>ALIGNED</code> to align on 4 byte
+boundaries. To align on 2<b><sup>n</sup></b> byte boundaries,
+set <code>FICL_ALIGN</code> to <b>n</b>.
+
+
+<dt><b>
+behavior of 6.1.1320 EMIT for non-graphic characters
+</b><dd>
+
+
+
+Depends on target system, C runtime library, and your
+implementation of <code>ficlTextOut()</code>.
+
+
+<dt><b>
+character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT
+</b><dd>
+
+
+
+None implemented in the versions supplied in <code>primitives.c</code>.
+Because <code>ficlEvaluate()</code> is supplied a text buffer
+externally, it's up to your system to define how that buffer will
+be obtained.
+
+
+<dt><b>
+character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750 KEY)
+</b><dd>
+
+
+
+Depends on target system and implementation of <code>ficlTextOut()</code>.
+
+
+<dt><b>
+character-aligned address requirements (3.1.3.3 Addresses)
+</b><dd>
+
+
+
+Ficl characters are one byte each. There are no alignment requirements.
+
+
+<dt><b>
+character-set-extensions matching characteristics (3.4.2 Finding definition names)
+</b><dd>
+
+
+
+No special processing is performed on characters beyond case-folding. Therefore,
+extended characters will not match their unaccented counterparts.
+
+
+<dt><b>
+conditions under which control characters match a space delimiter (3.4.1.1 Delimiters)
+</b><dd>
+
+
+
+Ficl uses the Standard C function <code>isspace()</code> to distinguish space characters.
+
+
+<dt><b>
+format of the control-flow stack (3.2.3.2 Control-flow stack)
+</b><dd>
+
+
+
+Uses the data stack.
+
+
+<dt><b>
+conversion of digits larger than thirty-five (3.2.1.2 Digit conversion)
+</b><dd>
+
+
+
+The maximum supported value of <code>BASE</code> is 36.
+Ficl will fail via assertion in function <code>ltoa()</code> of <code>utility.c</code>
+if the base is found to be larger than 36 or smaller than 2. There will be no effect
+if <code>NDEBUG</code> is defined, however, other than possibly unexpected behavior.
+
+
+<dt><b>
+display after input terminates in 6.1.0695 ACCEPT and 6.2.1390 EXPECT
+</b><dd>
+
+
+
+Target system dependent.
+
+
+<dt><b>
+exception abort sequence (as in 6.1.0680 ABORT")
+</b><dd>
+
+
+
+Calls <tt>ABORT</tt> to exit.
+
+
+<dt><b>
+input line terminator (3.2.4.1 User input device)
+</b><dd>
+
+
+
+Target system dependent (implementation of outer loop that calls <code>ficlEvaluate()</code>).
+
+
+<dt><b>
+maximum size of a counted string, in characters (3.1.3.4 Counted strings, 6.1.2450 WORD)
+</b><dd>
+
+
+
+Counted strings are limited to 255 characters.
+
+
+<dt><b>
+maximum size of a parsed string (3.4.1 Parsing)
+</b><dd>
+
+
+
+Limited by available memory and the maximum unsigned value that can fit in a cell (2<sup>32</sup>-1).
+
+
+<dt><b>
+maximum size of a definition name, in characters (3.3.1.2 Definition names)
+</b><dd>
+
+
+
+Ficl stores the first 31 characters of a definition name.
+
+
+<dt><b>
+maximum string length for 6.1.1345 ENVIRONMENT?, in characters
+</b><dd>
+
+
+
+Same as maximum definition name length.
+
+
+<dt><b>
+method of selecting 3.2.4.1 User input device
+</b><dd>
+
+
+
+None supported. This is up to the target system.
+
+
+<dt><b>
+method of selecting 3.2.4.2 User output device
+</b><dd>
+
+
+
+None supported. This is up to the target system.
+
+
+<dt><b>
+methods of dictionary compilation (3.3 The Forth dictionary)
+</b><dd>
+
+
+
+Okay, we don't know what this means. If you understand what they're asking for here,
+please call the home office.
+
+
+<dt><b>
+number of bits in one address unit (3.1.3.3 Addresses)
+</b><dd>
+
+
+
+Target system dependent, either 32 or 64 bits.
+
+
+<dt><b>
+number representation and arithmetic (3.2.1.1 Internal number representation)
+</b><dd>
+
+
+
+System dependent. Ficl represents a CELL internally as a union that can hold a <code>ficlInteger32</code>
+(a signed 32 bit scalar value), a <code>ficlUnsigned32</code> (32 bits unsigned),
+and an untyped pointer. No specific byte ordering is assumed.
+
+
+<dt><b>
+ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types, 3.1.4 Cell-pair types)
+</b><dd>
+
+
+
+System dependent.
+Assuming a 32 bit implementation, range for signed single-cell values is [-2<sup>31</sup>, 2<sup>31</sup>-1].
+Range for unsigned single cell values is [0, 2<sup>32</sup>-1].
+Range for signed double-cell values is [-2<sup>63</sup>, 2<sup>63</sup>-1].
+Range for unsigned double cell values is [0, 2<sup>64</sup>-1].
+
+
+<dt><b>
+read-only data-space regions (3.3.3 Data space)
+</b><dd>
+
+
+
+None.
+
+
+<dt><b>
+size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient regions)
+</b><dd>
+
+
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<dt><b>
+size of one cell in address units (3.1.3 Single-cell types)
+</b><dd>
+
+
+
+System dependent, generally 4.
+
+
+<dt><b>
+size of one character in address units (3.1.2 Character types)
+</b><dd>
+
+
+
+System dependent, generally 1.
+
+
+<dt><b>
+size of the keyboard terminal input buffer (3.3.3.5 Input buffers)
+</b><dd>
+
+
+
+This buffer is supplied by the host program. Ficl imposes no practical limit.
+
+
+<dt><b>
+size of the pictured numeric output string buffer (3.3.3.6 Other transient regions)
+</b><dd>
+
+
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<dt><b>
+size of the scratch area whose address is returned by 6.2.2000 PAD (3.3.3.6 Other transient regions)
+</b><dd>
+
+
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<dt><b>
+system case-sensitivity characteristics (3.4.2 Finding definition names)
+</b><dd>
+
+
+
+The Ficl dictionary is not case-sensitive.
+
+
+<dt><b>
+system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)
+</b><dd>
+
+
+
+<code>ok&gt;</code>
+
+
+<dt><b>
+type of division rounding (3.2.2.1 Integer division, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)
+</b><dd>
+
+
+
+Symmetric.
+
+
+<dt><b>
+values of 6.1.2250 STATE when true
+</b><dd>
+
+
+
+1.
+
+
+<dt><b>
+values returned after arithmetic overflow (3.2.2.2 Other integer operations)
+</b><dd>
+
+
+
+System dependent. Ficl makes no special checks for overflow.
+
+
+<dt><b>
+whether the current definition can be found after 6.1.1250 DOES&gt; (6.1.0450 :)
+</b><dd>
+
+
+No. Definitions are unsmudged after ; only, and only then if no control structure matching problems have been detected.
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='AmbiguousConditions'>
+Ambiguous Conditions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<dt><b>
+a name is neither a valid definition name nor a valid number during text interpretation (3.4 The Forth text interpreter)
+</b><dd>
+
+
+
+Ficl calls <code>ABORT</code> then prints the name followed by <code>not found</code>.
+
+
+<dt><b>
+a definition name exceeded the maximum length allowed (3.3.1.2 Definition names)
+</b><dd>
+
+
+
+Ficl stores the first 31 characters of the definition name, and uses all characters of the name
+in computing its hash code. The actual length of the name, up to 255 characters, is stored in
+the definition's length field.
+
+
+<dt><b>
+addressing a region not listed in 3.3.3 Data Space
+</b><dd>
+
+
+
+No problem: all addresses in Ficl are absolute. You can reach any 32 bit address in Ficl's address space.
+
+
+<dt><b>
+argument type incompatible with specified input parameter, e.g., passing a flag to a word expecting an n (3.1 Data types)
+</b><dd>
+
+
+
+Ficl makes no check for argument type compatibility. Effects of a mismatch vary widely depending on the specific problem and operands.
+
+
+<dt><b>
+attempting to obtain the execution token, (e.g., with 6.1.0070 ', 6.1.1550 FIND, etc.) of a definition with undefined interpretation semantics
+</b><dd>
+
+
+
+Ficl returns a valid token, but the result of executing that token while interpreting may be undesirable.
+
+
+<dt><b>
+dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 8.6.1.1820 M*/)
+</b><dd>
+
+
+
+Results are target procesor dependent. Generally, Ficl makes no check for divide-by-zero. The target processor will probably throw an exception.
+
+
+<dt><b>
+insufficient data-stack space or return-stack space (stack overflow)
+</b><dd>
+
+
+
+With <code>FICL_ROBUST</code> (defined in <code>ficl.h</code>) set to a value of 2 or greater,
+most data, float, and return stack operations are checked for underflow and overflow.
+
+
+<dt><b>
+insufficient space for loop-control parameters
+</b><dd>
+
+
+
+This is not checked, and bad things will happen.
+
+
+<dt><b>
+insufficient space in the dictionary
+</b><dd>
+
+
+
+Ficl generates an error message if the dictionary is too full to create
+a definition header. It checks <code>ALLOT</code> as well, but it is possible
+to make an unchecked allocation request that will overflow the dictionary.
+
+
+<dt><b>
+interpreting a word with undefined interpretation semantics
+</b><dd>
+
+
+
+Ficl protects all ANS Forth words with undefined interpretation semantics from being executed while in interpret state.
+It is possible to defeat this protection using ' (tick) and <code>EXECUTE</code> though.
+
+
+<dt><b>
+modifying the contents of the input buffer or a string literal (3.3.3.4 Text-literal regions, 3.3.3.5 Input buffers)
+</b><dd>
+
+
+
+Varies depending on the nature of the buffer. The input buffer is supplied by ficl's host function, and may reside
+in read-only memory. If so, writing the input buffer can ganerate an exception.
+String literals are stored in the dictionary, and are writable.
+
+
+<dt><b>
+overflow of a pictured numeric output string
+</b><dd>
+
+
+
+In the unlikely event you are able to construct a pictured numeric string of more
+than <code>FICL_PAD_LENGTH</code> characters, the system will be corrupted unpredictably.
+The buffer area that holds pictured numeric output is at the end of the virtual machine.
+Whatever is mapped after the offending VM in memory will be trashed, along with the heap
+structures that contain it.
+
+
+<dt><b>
+parsed string overflow
+</b><dd>
+
+
+
+Ficl does not copy parsed strings unless asked to. Ordinarily, a string parsed from the input buffer during
+normal interpretation is left in-place, so there is no possibility of overflow.
+If you ask to parse a string into the dictionary, as in <code>SLITERAL</code>, you need to have enough
+room for the string, otherwise bad things may happen. This is usually not a problem.
+
+
+<dt><b>
+producing a result out of range, e.g., multiplication (using *) results in a value too big to be represented by a single-cell integer (6.1.0090 *, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570, &gt;NUMBER, 6.1.1561 FM/MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 6.2.0970 CONVERT, 8.6.1.1820 M*/)
+</b><dd>
+
+
+
+Value will be truncated.
+
+
+<dt><b>
+reading from an empty data stack or return stack (stack underflow)
+</b><dd>
+
+
+
+Most stack underflows are detected and prevented if <code>FICL_ROBUST</code> (defined in <code>sysdep.h</code>) is set to 2 or greater.
+Otherwise, the stack pointer and size are likely to be trashed.
+
+
+<dt><b>
+unexpected end of input buffer, resulting in an attempt to use a zero-length string as a name
+</b><dd>
+
+
+
+Ficl returns for a new input buffer until a non-empty one is supplied.
+
+
+</dl>
+
+
+The following specific ambiguous conditions are noted in the glossary entries of the relevant words:
+
+<dl>
+
+<dt><b>
+&gt;IN greater than size of input buffer (3.4.1 Parsing)
+</b><dd>
+
+
+
+Memory corruption will occur&mdash;the exact behavior is unpredictable
+because the input buffer is supplied by the host program's outer loop.
+
+
+<dt><b>
+6.1.2120 RECURSE appears after 6.1.1250 DOES&gt;
+</b><dd>
+
+
+
+It finds the address of the definition before <code>DOES&gt;</code>
+
+
+<dt><b>
+argument input source different than current input source for 6.2.2148 RESTORE-INPUT
+</b><dd>
+
+
+
+Not implemented.
+
+
+<dt><b>
+data space containing definitions is de-allocated (3.3.3.2 Contiguous regions)
+</b><dd>
+
+
+
+This is okay until the cells are overwritten with something else.
+The dictionary maintains a hash table, and the table must be updated
+in order to de-allocate words without corruption.
+
+
+<dt><b>
+data space read/write with incorrect alignment (3.3.3.1 Address alignment)
+</b><dd>
+
+
+
+Target processor dependent. Consequences include: none (Intel), address error exception (68K).
+
+
+<dt><b>
+data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860 C,)
+</b><dd>
+
+
+
+See above on data space read/write alignment.
+
+<dt><b>
+less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)
+</b><dd>
+
+
+
+If <code>FICL_ROBUST</code> is two or larger, Ficl will detect a stack underflow, report it, and execute <code>ABORT</code> to
+exit execution. Otherwise the error will not be detected, and memory corruption will occur.
+
+
+<dt><b>
+loop-control parameters not available ( 6.1.0140 +LOOP, 6.1.1680 I, 6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)
+</b><dd>
+
+
+
+Loop initiation words are responsible for checking the stack and guaranteeing that the control parameters are pushed.
+Any underflows will be detected early if <code>FICL_ROBUST</code> is set to 2 or greater.
+Note however that Ficl only checks for return stack underflows at the end of each line of text.
+
+<dt><b>
+most recent definition does not have a name (6.1.1710 IMMEDIATE)
+</b><dd>
+
+
+
+No problem.
+
+
+<dt><b>
+name not defined by 6.2.2405 VALUE used by 6.2.2295 TO
+</b><dd>
+
+
+
+Ficl's version of <code>TO</code> works correctly with words defined with:
+<ul>
+
+<li> <code>VALUE</code>
+<li> <code>2VALUE</code>
+<li> <code>FVALUE</code>
+<li> <code>F2VALUE</code>
+<li> <code>CONSTANT</code>
+<li> <code>FCONSTANT</code>
+<li> <code>2CONSTANT</code>
+<li> <code>F2CONSTANT</code>
+<li> <code>VARIABLE</code>
+<li> <code>2VARIABLE</code>
+</ul>
+as well as with all "local" variables.
+
+<dt><b>
+name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['], 6.2.2530 [COMPILE])
+</b><dd>
+
+
+
+Ficl prints an error message and executes <code>ABORT</code>
+
+<dt><b>
+parameters are not of the same type (6.1.1240 DO, 6.2.0620 ?DO, 6.2.2440 WITHIN)
+</b><dd>
+
+
+
+Not detected. Results vary depending on the specific problem.
+
+
+<dt><b>
+6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO
+</b><dd>
+
+
+
+The word is postponed correctly.
+
+
+<dt><b>
+string longer than a counted string returned by 6.1.2450 WORD
+</b><dd>
+
+
+
+Ficl stores the first <code>FICL_COUNTED_STRING_MAX</code> - 1 characters in the
+destination buffer.
+(The extra character is the trailing space required by the standard. Yuck.)
+
+<dt><b>
+u greater than or equal to the number of bits in a cell (6.1.1805 LSHIFT, 6.1.2162 RSHIFT)
+</b><dd>
+
+
+
+Depends on target process or and C runtime library implementations of the &lt;&lt; and &gt;&gt; operators
+on unsigned values. For I386, the processor appears to shift modulo the number of bits in a cell.
+
+<dt><b>
+word not defined via 6.1.1000 CREATE (6.1.0550 &gt;BODY, 6.1.1250 DOES&gt;)
+</b><dd>
+
+
+
+<dt><b>
+words improperly used outside 6.1.0490 &lt;# and 6.1.0040 #&gt; (6.1.0030 #, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)
+</b><dd>
+
+
+
+Undefined. <code>CREATE</code> reserves a field in words it builds for <code>DOES&gt;</code> to fill in.
+If you use <code>DOES&gt;</code> on a word not made by <code>CREATE</code> it will overwrite the first
+cell of its parameter area. That's probably not what you want. Likewise, pictured numeric words
+assume that there is a string under construction in the VM's scratch buffer. If that's not the case,
+results may be unpleasant.
+
+
+</dl>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='LocalsImplementation-DefinedOptions'>
+Locals Implementation-Defined Options
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<dt><b>
+maximum number of locals in a definition (13.3.3 Processing locals, 13.6.2.1795 LOCALS|)
+</b><dd>
+
+
+
+Default is 64&mdash;unused locals are cheap. Change by redefining <code>FICL_MAX_LOCALS</code> (defined in <code>ficl.h</code>).
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='LocalsAmbiguousconditions'>
+Locals Ambiguous conditions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<dt><b>
+executing a named local while in interpretation state (13.6.1.0086 (LOCAL))
+</b><dd>
+
+
+
+Locals can be found in interpretation state while in the context of a definition under
+construction. Under these circumstances, locals behave correctly. Locals are not visible
+at all outside the scope of a definition.
+
+<dt><b>
+name not defined by VALUE or LOCAL (13.6.1.2295 TO)
+</b><dd>
+
+
+
+See the CORE ambiguous conditions, above (no change).
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='ProgrammingToolsImplementation-DefinedOptions'>
+Programming Tools Implementation-Defined Options
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+<dl>
+
+<dt><b>
+source and format of display by 15.6.1.2194 SEE
+</b><dd>
+
+
+
+<code>SEE</code> de-compiles definitions from the dictionary. Ficl words are stored as a combination
+of things:
+<ol>
+
+<li>bytecodes (identified as "instructions"),
+<li>addresses of native Ficl functions, and
+<li>arguments to both of the above.
+
+</ol>
+Colon definitions are decompiled. Branching instructions indicate their destination,
+but target labels are not reconstructed.
+Literals and string literals are so noted, and their contents displayed.
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='SearchOrderImplementation-DefinedOptions'>
+Search Order Implementation-Defined Options
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+<dl>
+
+<dt><b>
+maximum number of word lists in the search order (16.3.3 Finding definition names, 16.6.1.2197 SET-ORDER)
+</b><dd>
+
+
+
+Defaults to 16. Can be changed by redefining <code>FICL_MAX_WORDLISTS</code> (declared in <code>ficl.h</code>).
+
+
+<dt><b>
+minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)
+</b><dd>
+
+
+
+Equivalent to <code>FORTH-WORDLIST 1 SET-ORDER</code>
+
+</dl>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='SearchOrderAmbiguousConditions'>
+Search Order Ambiguous Conditions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+<dl>
+<dt><b>
+changing the compilation word list (16.3.3 Finding definition names)
+</b><dd>
+
+
+
+Ficl stores a link to the current definition independently of the compile wordlist while
+it is being defined, and links it into the compile wordlist only after the definition completes
+successfully. Changing the compile wordlist mid-definition will cause the definition to link
+into the <i>new</i> compile wordlist.
+
+
+<dt><b>
+search order empty (16.6.2.2037 PREVIOUS)
+</b><dd>
+
+
+
+Ficl prints an error message if the search order underflows, and resets the order to its default state.
+
+
+<dt><b>
+too many word lists in search order (16.6.2.0715 ALSO)
+</b><dd>
+
+
+
+Ficl prints an error message if the search order overflows, and resets the order to its default state.
+
+</dl>
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/favicon.ico b/doc/favicon.ico
index 57b1c723f583..027a7bd6b072 100644
--- a/doc/favicon.ico
+++ b/doc/favicon.ico
Binary files differ
diff --git a/doc/ficl.html b/doc/ficl.html
index a3096a4e5d33..3c23c0dde130 100644
--- a/doc/ficl.html
+++ b/doc/ficl.html
@@ -1,185 +1,264 @@
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
<!DOCTYPE html PUBLIC "-//w3c//dtd html 4.0 transitional//en">
-<HTML>
- <HEAD>
- <META name="Author" content="john sadler">
- <META name="Description" content="Ficl - embedded scripting with object oriented programming">
- <META name="Keywords" content="scripting prototyping tcl OOP Forth interpreter C">
-<STYLE>
-
-</STYLE>
- <LINK rel="SHORTCUT ICON" href="ficl.ico">
- <TITLE>
- Ficl - Embedded Scripting
- </TITLE>
- </HEAD>
- <BODY>
- <H1>
- <B>Ficl Documentation</B>
- </H1>
-<SCRIPT language="javascript" src="ficlheader.js" type="text/javascript">
-</SCRIPT>
- <DIV style="width:675px">
- <BR>
-
- <H1>
- <A name="whatis"></A>What is ficl?
- </H1>
- Ficl is a complete programming language interpreter designed to be embedded into other systems (including firmware based ones) as a command, macro, and development prototype language. Unlike other scripting interpreters,
- Ficl:
- <UL>
- <LI>
- typically takes under 2 hours to port to a new system -- much less if the target operating system is one of several already supported (Win32, Linux, FreeBSD, RiscOS, and more)
- </LI>
- <LI>
- has a small memory footprint: a fully featured Win32 console version takes less than 100K of memory, and a minimal version is less than half that
- </LI>
- <LI>
- is relatively quick thanks to its threaded code virtual machine design and just in time compiling
- </LI>
- <LI>
- is a complete and powerful programming language
- </LI>
- <LI>
- is interactive
- </LI>
- <LI>
- has object oriented programming features that can be used to wrap data structures or classes of the host system without altering them - even if the host is mainly written in a non-OO
- language
- </LI>
- </UL>
- <P>
- Ficl syntax is based on ANS Forth and the code is Standard C. See below for examples of <A href="#includesficl">software and products that include ficl</A>. Ficl stands for "Forth inspired
- command language".&nbsp;
- </P>
- <H3>
- Ficl vs. other Forth interpreters
- </H3>
- Where Forths usually view themselves as the center of the system and expect the rest of the system to be coded in Forth, Ficl acts as a component of the system. It is easy to export code
- written in C or ASM to Ficl in the style of TCL, or to invoke Ficl code from a compiled module. This allows you to do incremental development in a way that combines the best features of
- threaded languages (rapid development, quick code/test/debug cycle, reasonably fast) with the best features of C (everyone knows it, easier to support large blocks of code, efficient, type
- checking). In addition, Ficl provides a simple and powerful object model that can act as an object oriented <I>adapter</I> for code written in C (or asm, Forth, C++...).&nbsp;
- <H3>
- Ficl Design goals
- </H3>
- <UL>
- <LI>
- Target 32 bit processors (<I>version 2.03 targets 64 bit processors too</I>)
- </LI>
- <LI>
- Scripting, prototyping, and extension language for systems written also in C
- </LI>
- <LI>
- Supportable - code is as transparent as I can make it
- </LI>
- <LI>
- Interface to functions written in C
- </LI>
- <LI>
- Conform to the Forth DPANS 94
- </LI>
- <LI>
- Minimize porting effort - require an ANSI C runtime environment and minimal glue code
- </LI>
- <LI>
- Provide object oriented extensions
- </LI>
- </UL>
- <HR>
- <H2>
- <A name="download"></A>Download
- </H2>
- <UL>
- <LI>
- <B><A href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download ficl (latest release)</A></B>
- </LI>
- </UL>
- <H2>
- <A name="links"></A>More information on Ficl and Forth
- </H2>
- <UL>
- <LI>
- <A href="http://ficl.sourceforge.net">Web home of Ficl</A>
- </LI>
- <LI>
- <A href="http://ficl.sourceforge.net/pdf/Forth_Primer.pdf">An excellent Forth Primer by Hans Bezemer</A>
- </LI>
- <LI>
- <A href="ficlddj.pdf">Manuscript of Ficl article for January 1999 Dr. Dobb's Journal</A>
- </LI>
- <LI>
- <A href="jwsforml.pdf">1998 FORML Conference paper - OO Programming in Ficl</A>
- </LI>
- <LI>
- <A href="http://www.taygeta.com/forth_intro/stackflo.html">An Introduction to Forth using Stack Flow</A> (start here if you're new to Forth)
- </LI>
- <LI>
- <A href="http://www.softsynth.com/pforth/pf_tut.htm">Phil Burk's Forth Tutorial</A>
- </LI>
- <LI>
- <A href="http://www.complang.tuwien.ac.at/forth/threaded-code.html">Anton Ertl's description of Threaded Code</A>
- </LI>
- <LI>
- <A href="http://ficl.sourceforge.net/dpans/dpans.htm">Draft Proposed American National Standard for Forth</A> (quite readable, actually)
- </LI>
- <LI>
- <A href="http://www.taygeta.com/forthlit.html">Forth literature index on Taygeta</A>
- </LI>
- <LI>
- <A href="http://www.forth.org">Forth Interest Group</A>
- </LI>
- </UL>
- <H2>
- <A name="includesficl"></A>Some software that uses ficl
- </H2>
- <UL>
- <LI>
- <A href="http://www.freebsd.org/">FreeBSD</A> boot loader (Daniel Sobral, Jordan Hubbard)
- </LI>
- <LI>
- <A href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">SwitchCore</A> Gigabit Ethernet switches (&Ouml;rjan Gustavsson )
- </LI>
- <LI>
- <A href="http://debuffer.sourceforge.net/">Palm Pilot Debuffer</A> (Eric Sessoms) Also see ficlx, a C++ interface to ficl, on the same site
- </LI>
- <LI>
- <A href="http://www.swcp.com/~jchavez/osmond.html">Osmond PC Board Layout tool</A>
- </LI>
- <LI>
- <A href="http://www.netcomsystems.com">NetCom Systems</A> ML7710
- </LI>
- <LI>
- <A href="http://www.parview.com/ds/homepage.html">ParView</A> GPS system
- </LI>
- <LI>
- <A href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">PowerPlant Software</A> Development Environment for Linux
- </LI>
- <LI>
- <A href="http://www.vyyo.com/products/architecture_v3000.html">Vyyo V3000 Broadband Wireless Hub</A>
- </LI>
- <LI>
- <A href="mailto:john_sadler@alum.mit.edu"><I>Your Product Name Here!!!</I></A>
- </LI>
- </UL>
- <HR>
- <H2>
- <A name="lawyerbait"></A>LICENSE and DISCLAIMER
- </H2>
- <P>
- Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) All rights reserved.
- </P>
- <P>
- 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
- <A href="mailto:john_sadler@alum.mit.edu">send me email</A>.&nbsp;
- </P>
-<PRE>
+
+<html>
+<head>
+ <meta name="Author" content="john sadler">
+ <meta name="Description" content="Ficl - embedded scripting with object oriented programming">
+ <meta name="Keywords" content="scripting prototyping tcl OOP Forth interpreter C">
+ <link rel="SHORTCUT ICON" href="favicon.ico">
+ <title>Ficl - Embedded Scripting</title>
+</head>
+
+<body>
+
+<h1>Ficl Documentation</h1>
+
+<script language="javascript" src="ficlheader.js" type="text/javascript">
+</script>
+
+<h1><a name="whatis">What is Ficl?</a></h1>
+Ficl is a complete programming language interpreter designed to be
+embedded into other systems (including firmware based ones) as a
+command, macro, and development prototype language. Unlike other
+scripting interpreters, Ficl:
+
+<ul>
+
+<li>
+typically takes under 2 hours to port to a new system&mdash;much
+less if the target operating system is one of several already supported
+(Win32, Linux, FreeBSD, RiscOS, and more)
+
+<li>
+has a small memory footprint: a fully featured Win32 console
+version takes less than 100K of memory, and a minimal version is less
+than half that
+
+<li>
+is relatively quick thanks to its "switch-threaded" virtual
+machine design and just in time compiling
+
+<li>
+is a complete and powerful programming language
+
+<li>
+is interactive
+
+<li>
+has object oriented programming features that can be used to wrap
+data structures or classes of the host system without altering them&#151;even
+if the host is mainly written in a non-OO language
+
+</ul>
+
+<p>
+
+Ficl syntax is based on ANS Forth and the code is ANSI C. See
+below for examples of <a href="#includesficl">software and products
+that include ficl</a>. Ficl stands for "Forth inspired command language".
+
+
+<h3>Ficl Versus Other Forth Interpreters</h3>
+
+Where most Forths view themselves as the center of the system and
+expect the rest of the system to be coded in Forth, Ficl acts as a
+component of the system. It is easy to export code written in C or
+ASM to Ficl in the style of TCL, or to invoke Ficl code from a compiled
+module. This allows you to do incremental development in a way that
+combines the best features of threaded languages (rapid
+development, quick code/test/debug cycle, reasonably fast) with the best
+features of C (everyone knows it, easier to support large blocks of
+code, efficient, type checking). In addition, Ficl provides a simple
+and powerful object model that can act as an object oriented <i>adapter</i>
+for code written in C (or asm, Forth, C++...).
+
+
+<h3>Ficl Design Goals</h3>
+<ul>
+
+<li>
+Target 32- and 64-bit processors
+
+<li>
+Scripting, prototyping, and extension language for systems
+written also in C
+
+<li>
+Supportable&mdash;code is as transparent as I can make it
+
+<li>
+Interface to functions written in C
+
+<li>
+Conformant to the 1994 ANSI Standard for Forth (DPANS94)
+
+<li>
+Minimize porting effort&mdash;require an ANSI C runtime environment
+and minimal glue code
+
+<li>
+Provide object oriented extensions
+
+</ul>
+
+<hr>
+
+<h2><a name="download">Download</a></h2>
+
+<ul>
+
+<li> <b><a href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download Ficl (latest release)</a></b>
+
+</ul>
+
+<h2><a name="links">More information on Ficl and Forth</a></h2>
+
+<ul>
+
+<li>
+<a href="http://ficl.sourceforge.net">Web home of Ficl</a>
+
+<li>
+<a href="http://ficl.sourceforge.net/pdf/Forth_Primer.pdf">
+An excellent Forth Primer by Hans Bezemer
+</a>
+
+<li>
+<a href="ficlddj.pdf">
+Manuscript of Ficl article for January 1999 Dr. Dobb's Journal
+</a>
+
+<li>
+<a href="jwsforml.pdf">
+1998 FORML Conference paper&mdash;OO Programming in Ficl
+</a>
+
+<li>
+<a href="http://www.taygeta.com/forth_intro/stackflo.html">
+An Introduction to Forth using Stack Flow
+</a>
+(start here if you're new to Forth)
+
+<li>
+<a href="http://www.softsynth.com/pforth/pf_tut.htm">
+Phil Burk's Forth Tutorial
+</a>
+
+<li>
+<a href="http://www.complang.tuwien.ac.at/forth/threaded-code.html">
+Anton Ertl's description of Threaded Code
+</a>
+(Ficl now uses what he calls "switch threading")
+
+<li>
+<a href="http://ficl.sourceforge.net/dpans/dpans.htm">
+Draft Proposed American National Standard for Forth
+</a>
+(quite readable, actually)
+
+<li>
+<a href="http://www.taygeta.com/forthlit.html">
+Forth literature index on Taygeta
+</a>
+
+<li>
+<a href="http://www.forth.org">
+Forth Interest Group
+</a>
+
+</ul>
+
+<h2><a name="includesficl">Some software that uses Ficl</a></h2>
+
+<ul>
+<li>
+The <a href="http://www.freebsd.org/">FreeBSD</a> boot loader
+(Daniel Sobral, Jordan Hubbard)
+
+<li>
+<a href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">
+SwitchCore
+</a>
+Gigabit Ethernet switches (&Ouml;rjan Gustavsson )
+
+<li>
+<a href="http://debuffer.sourceforge.net/">
+Palm Pilot Debuffer
+</a>
+(Eric Sessoms) Also see ficlx, a C++ interface to ficl, on the same site
+
+<li>
+<a href="http://www.swcp.com/%7Ejchavez/osmond.html">
+Osmond PC Board Layout tool
+</a>
+
+<li>
+<a href="http://www.netcomsystems.com">
+NetCom Systems
+</a>
+ML7710
+
+<li>
+<a href="http://www.parview.com/ds/homepage.html">
+ParView
+</a>
+GPS system
+
+<li>
+<a href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">
+PowerPlant Software
+</a>
+Development Environment for Linux
+
+<li>
+<a href="http://www.vyyo.com/products/architecture_v3000.html">
+Vyyo V3000 Broadband Wireless Hub
+</a>
+
+<li>
+<a href="mailto:john_sadler@alum.mit.edu">
+<i>Your Product Name Here!!!</i>
+</a>
+
+</ul>
+
+
+<hr>
+<h2><a name="lawyerbait">License And Disclaimer</a></h2>
+
+Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+<br>
+All rights reserved.
+<p>
+
+<b>
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.
+<ol>
+
+<li>
+Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+<li>
+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.
+
+</ol>
THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
@@ -192,1328 +271,999 @@ 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.
-</PRE>
- &nbsp;
- <H2>
- <A name="features"></A>Ficl features
- </H2>
- <UL>
- <LI>
- Simple to integrate into existing systems: the sample implementation requires three Ficl function calls (see the example program in testmain.c).
- </LI>
- <LI>
- Written in ANSI C for portability.&nbsp;
- </LI>
- <LI>
- Standard: Implements the ANS Forth CORE word set, part of the CORE EXT word set, SEARCH and SEARCH EXT, TOOLS and part of TOOLS EXT, LOCAL and LOCAL EXT, EXCEPTION, MEMORY,&nbsp; and
- various extras.
- </LI>
- <LI>
- Extensible: you can export code written in Forth, C, or asm in a straightforward way. Ficl provides open facilities for extending the language in an application specific way. You can even
- add new control structures (not surprising if you're familiar with Forth)
- </LI>
- <LI>
- Ficl and C/C++ can interact in two ways: Ficl can wrap C code, and C functions can invoke ficl code.
- </LI>
- <LI>
- Ficl code is thread safe and re-entrant:&nbsp; All Ficl Virtual Machines share one system dictionary (version 3.0 will permit multiple dictionaries); each Ficl Virtual Machine has an
- otherwise complete state, and each can be bound to a separate I/O channel (or none at all). An optional function called ficlLockDictionary() can control exclusive dictionary access. This
- function is stubbed out by default (See FICL_MULTITHREAD in sysdep.h). As long as there is only one "session" that can compile words into the dictionary, you do not need exclusive
- dictionary access for multithreading. <B>Note</B>: while the code is re-entrant, there are still restrictions on how you can use it safely in a multithreaded system. Specifically, the VM
- itself maintains state, so you generally need a VM per thread in a multithreaded system. If interrupt service routines make calls into Ficl code that alters VM state, then these generally
- need their own VM as well. Alternatively, you could provide a mutual exclusion mechanism to serialize access to a VM from multiple threads.
- </LI>
- <LI>
- ROMable: Ficl is designed to work in RAM based and ROM code / RAM data environments. It does require somewhat more memory than a pure ROM implementation because it builds its system
- dictionary in RAM at startup time.
- </LI>
- <LI>
- Written in ANSI C to be as simple as I can make it to understand, support, debug, and port. Compiles without complaint at /Az /W4 (require ANSI C, max. warnings) under Microsoft VC++. Ports
- to several other toolchains and operating systems (notably FreeBSD and Linux flavors) exist.
- </LI>
- <LI>
- Does full 32 bit math (but you need to implement two mixed precision math primitives (see sysdep.c))
- </LI>
- </UL>
- <HR>
- <H2>
- <A name="porting"></A>Porting ficl
- </H2>
- To install ficl on your target system, you need an ANSI C compiler and its runtime library. Inspect the system dependent macros and functions in <TT>sysdep.h</TT> and <TT>sysdep.c</TT> and edit
- them to suit your system. For example, <TT>INT16</TT> is a <TT>short</TT> on some compilers and an <TT>int</TT> on others. Check the default <TT>CELL</TT> alignment controlled by <TT>
- FICL_ALIGN</TT>. If necessary, add new definitions of <TT>ficlMalloc, ficlFree, ficlRealloc</TT>, and <TT>ficlTextOut</TT> to work with your operating system. Finally, use <TT>testmain.c</TT>
- as a guide to installing the ficl system and one or more virtual machines into your code. You do not need to include <TT>testmain.c</TT> in your build.&nbsp;
- <P>
- Note: ficlLockDictionary can be left unimplemented in most multithreaded implementations - it's only necessary if you expect to have more than one thread modifying the dictionary at the same
- time. If you do decide to implement it, make sure calls to ficlLockDictionary can nest properly (see the comments in sysdep.h). You need to keep count of nested locks and unlocks and do the
- right thing.
- </P>
- <P>
- Feel free to stub out the double precision math functions (which are presently implemented as inline assembly because it's so easy on many 32 bit processors) with kludge code that only goes
- to 32 bit precision. In most applications, you won't notice the difference. If you're doing a lot of number crunching, consider implementing them correctly.&nbsp;
- </P>
- <H3>
- Build controls
- </H3>
- The file sysdep.h contains default values for build controls. Most of these are written such that if you define them on the compiler command line, the defaults are overridden. I suggest you
- take the defaults on everything below the "build controls" section until you're confident of your port. Beware of declaring too small a dictionary, for example. You need about 3200 cells for a
- full system, about 2000 if you strip out most of the "soft" words.&nbsp;
- <H3>
- Soft Words
- </H3>
- Many words from all the supported wordsets are written in Forth, and stored as a big string that Ficl compiles when it starts. The sources for all of these words are in directory
- ficl/softwords. There is a .bat file (softcore.bat) and a PERL 5 script (softcore.pl) that convert Forth files into the file softcore.c, so softcore.c is really dependent on the Forth sources.
- This is not reflected in the Visual C++ project database. For the time being, it's a manual step. You can edit softcore.bat to change the list of files that contribute to softcore.c.&nbsp;
- <H3>
- To-Do List (target system dependent words)
- </H3>
- <UL>
- <LI>
- Unimplemented system dependent <TT>CORE</TT> word: <TT>KEY</TT> (implement this yourself if you need it)
- </LI>
- <LI>
- Kludged <TT>CORE</TT> word: <TT>ACCEPT</TT> (implement this better if you need to)
- </LI>
- </UL>
- <BR>
- &nbsp;<BR>
- &nbsp;
- <H2>
- <A name="api"></A>Application Programming Interface
- </H2>
- The following is a partial listing of functions that interface your system or program to ficl. For a complete listing, see ficl.h (heavily commented). For examples, see testmain.c and the
- ficlwin sources (<A href="#download">below</A>). <I>See the comments in ficl.c and ficl.h for additional information, and the example in file testmain.c.</I>
- <DL>
- <DT>
- <B>FICL_SYSTEM *ficlInitSystem(int nDictCells)</B>
- </DT>
- <DD>
- Initializes Ficl's shared system data structures, and creates the dictionary allocating the specified number of CELLs from the heap (by a call to ficlMalloc)
- </DD>
- <DT>
- <B>void ficlTermSystem(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Reclaims memory allocated for the ficl system including all dictionaries and all virtual machines created by vmCreate. Any uses of the memory allocation words (allocate and resize) are your
- problem.
- </DD>
- <DT>
- <B>int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags)</B>
- </DT>
- <DD>
- Create a primitive word in ficl's main dictionary with the given name, code pointer, and properties (immediate, compile only, etc) as described by the flags (see ficl.h for flag
- descriptions of the form FW_XXXX)
- </DD>
- <DT>
- <B>int ficlExec(FICL_VM *pVM, char *text)</B>
- </DT>
- <DD>
- Feed the specified C string ('\0' terminated) to the given virtual machine for evaluation. Returns various exception codes (VM_XXXX in ficl.h) to indicate the reason for returning. Normal
- exit condition is VM_OUTOFTEXT, indicating that the VM consumed the string successfully and is back for more. ficlExec calls can be nested, and the function itself is re-entrant, but note
- that a VM is static, so you have to take reasonable precautions (for example, use one VM per thread in a multithreaded system if you want multiple threads to be able to execute commands).
- </DD>
- <DT>
- <B>int ficlExecC(FICL_VM *pVM, char *text, int nChars)</B>
- </DT>
- <DD>
- Same as ficlExec, but takes a count indicating the length of the supplied string. Setting nChars to -1 is equivalent to ficlExec (expects '\0' termination).
- </DD>
- <DT>
- <B>int ficlExecXT(FICL_VM *pVM, FICL_WORD *pFW)</B>
- </DT>
- <DD>
- Same as ficlExec, but takes a pointer to a FICL_WORD instead of a string. Executes the word and returns after it has finished. If executing the word results in an exception, this function
- will re-throw the same code if it is nested under another ficlExec family function, or return the exception code directly if not. This function is useful if you need to execute the same
- word repeatedly - you save the dictionary search and outer interpreter overhead.
- </DD>
- <DT>
- <B>void ficlFreeVM(FICL_VM *pVM)</B>
- </DT>
- <DD>
- Removes the VM in question from the system VM list and deletes the&nbsp; memory allocated to it. This is an optional call, since ficlTermSystem will do this cleanup for you. This function
- is handy if you're going to do a lot of dynamic creation of VMs.
- </DD>
- <DT>
- <B>FICL_VM *ficlNewVM(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Create, initialize, and return a VM from the heap using ficlMalloc. Links the VM into the system VM list for later reclamation by ficlTermSystem.
- </DD>
- <DT>
- <B>FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name)</B>
- </DT>
- <DD>
- Returns the address (also known as an XT in this case) of the specified word in the main dictionary. If not found, returns NULL. The address can be used in a call to ficlExecXT.
- </DD>
- <DT>
- <B>FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Returns a pointer to the main system dictionary, or NULL if the system is uninitialized.
- </DD>
- <DT>
- <B>FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Returns a pointer to the environment dictionary. This dictionary stores information that describes this implementation as required by the Standard.
- </DD>
- <DT>
- <B>void ficlSetEnv(FICL_SYSTEM *pSys, char *name, UNS32 value)</B>
- </DT>
- <DD>
- Enters a new constant into the environment dictionary, with the specified name and value.
- </DD>
- <DT>
- <B>void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, UNS32 hi, UNS32 lo)</B>
- </DT>
- <DD>
- Enters a new double-cell constant into the environment dictionary with the specified name and value.
- </DD>
- <DT>
- <B>FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Returns a pointer to the locals dictionary. This function is defined only if FICL_WANT_LOCALS is #defined as non-zero (see sysdep.h). The locals dictionary is the symbol table for <A href=
- "ficl_loc.html">local variables</A>.
- </DD>
- <DT>
- <B>void ficlCompileCore(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Defined in words.c, this function builds ficl's primitives.&nbsp;
- </DD>
- <DT>
- <B>void ficlCompileSoftCore(FICL_SYSTEM *pSys)</B>
- </DT>
- <DD>
- Defined in softcore.c, this function builds ANS required words and ficl extras by evaluating a text string (think of it as a memory mapped file ;-) ). The string itself is built from files
- in the softwords directory by PERL script softcore.pl.&nbsp;
- </DD>
- </DL>
- <HR>
- <TABLE border="0" cellspacing="5" cols="2">
- <TR>
- <TD colspan="2">
- <H2>
- <A name="manifest"></A>Ficl Source Files
- </H2>
- </TD>
- </TR>
- <TR>
- <TD>
- <B>ficl.h</B>
- </TD>
- <TD>
- Declares most public functions and all data structures. Includes sysdep.h and math.h
- </TD>
- </TR>
- <TR>
- <TD>
- <B>sysdep.h</B>
- </TD>
- <TD>
- Declares system dependent functions and contains build control macros. Edit this file to port to another system.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>math.h</B>
- </TD>
- <TD>
- Declares functions for 64 bit math
- </TD>
- </TR>
- <TR>
- <TD>
- <B>dict.c</B>
- </TD>
- <TD>
- Dictionary
- </TD>
- </TR>
- <TR>
- <TD>
- <B>ficl.c</B>
- </TD>
- <TD>
- System initialization, termination, and ficlExec
- </TD>
- </TR>
- <TR>
- <TD>
- <B>float.c</B>
- </TD>
- <TD>
- Adds precompiled definitions from the optional FLOAT word set. Most of the file is conditioned on FICL_WANT_FLOAT
- </TD>
- </TR>
- <TR>
- <TD>
- <B>math64.c</B>
- </TD>
- <TD>
- Implementation of 64 bit math words (except the two unsigned primitives declared in sysdep.h and implemented in sysdep.c)
- </TD>
- </TR>
- <TR>
- <TD>
- <B>prefix.c</B>
- </TD>
- <TD>
- The optional prefix parse step (conditioned on FICL_EXTENDED_PREFIX). This parse step handles numeric constructs like 0xa100, for example. See the release notes for more on parse steps.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>search.c</B>
- </TD>
- <TD>
- Contains C implementations of several of the SEARCH and SEARCH EXT words
- </TD>
- </TR>
- <TR>
- <TD>
- <B>softcore.c</B>
- </TD>
- <TD>
- Contains all of the "soft" words - those written in Forth and compiled by Ficl at startup time. Sources for these words are in the softwords directory. The files softwords/softcore.bat
- and softwords/softcore.pl generate softcore.c from the .fr sources.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>softwords/</B>
- </TD>
- <TD>
- Directory contains sources and translation scripts for the words defined in softcore.c. Softcore.c depends on most of the files in this directory. See softcore.bat for the actual list of
- files that contribute to softcore.c. This is where you'll find source code for the object oriented extensions. PERL script softcore.pl converts the .fr files into softcore.c.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>stack.c</B>
- </TD>
- <TD>
- Stack methods
- </TD>
- </TR>
- <TR>
- <TD>
- <B>sysdep.c</B>
- </TD>
- <TD>
- Implementation of system dependent functions declared in sysdep.h
- </TD>
- </TR>
- <TR>
- <TD>
- <B>testmain.c</B>
- </TD>
- <TD>
- The main() function for unix/linux/win32 console applications - use this as an example to integrate ficl into your system. Also contains some definitions for testing - also useful in
- unix/linux/win32 land.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>tools.c</B>
- </TD>
- <TD>
- Contains C implementations of TOOLS and TOOLS EXT words, the debugger, and debugger support words.
- </TD>
- </TR>
- <TR>
- <TD>
- <B>vm.c</B>
- </TD>
- <TD>
- Virtual Machine methods
- </TD>
- </TR>
- <TR>
- <TD>
- <B>win32.c &amp; unix.c</B>
- </TD>
- <TD>
- Platform extensions words loaded in ficl.c by ficlCompilePlatform() - conditioned on FICL_WANT_PLATFORM
- </TD>
- </TR>
- <TR>
- <TD>
- <B>words.c</B>
- </TD>
- <TD>
- Exports ficlCompileCore(), the run-time dictionary builder, and contains most precompiled CORE and CORE-EXT words.
- </TD>
- </TR>
- </TABLE>
- <HR>
- <H2>
- <A name="extras"></A>Ficl extras
- </H2>
- <H3>
- <A name="exnumber"></A>Number syntax
- </H3>
- You can precede a number with "0x", as in C, and it will be interpreted as a hex value regardless of the value of <CODE>BASE</CODE>. Likewise, numbers prefixed with "0d" will be interpreted as
- decimal values. Example:
-<PRE>
-ok&gt; decimal 123 . cr
-123
-ok&gt; 0x123 . cr
-291
-ok&gt; 0x123 x. cr
-123
-</PRE>
- Note: ficl2.05 and later - this behavior is controlled by the <A href="ficl_parse.html">prefix parser</A> defined in <CODE>prefix.c</CODE>. You can add other prefixes by defining handlers for
- them in ficl or C.
- <H3>
- <A name="exsearch"></A> The <CODE>SEARCH</CODE> wordset and Ficl extensions
- </H3>
- <P>
- Ficl implements many of the search order words in terms of two primitives called <CODE><A href="#tosearch">&gt;SEARCH</A></CODE> and <CODE><A href="#searchfrom">SEARCH&gt;</A></CODE>. As
- their names suggest (assuming you're familiar with Forth), they push and pop the search order stack.
- </P>
- <P>
- The standard does not appear to specify any conditions under which the search order is reset to a sane state. Ficl resets the search order to its default state whenever <TT>ABORT</TT>
- happens. This includes stack underflows and overflows. <TT>QUIT</TT> does not affect the search order. The minimum search order (set by <TT>ONLY</TT>) is equivalent to
- </P>
-<PRE>
-FORTH-WORDLIST 1 SET-ORDER
-</PRE>
- <P>
- There is a default maximum of 16 wordlists in the search order. This can be changed by redefining FICL_DEFAULT_VOCS (declared in sysdep.h).
- </P>
- <P>
- <B>Note</B>: Ficl resets the search order whenever it does <TT>ABORT</TT>. If you don't like this behavior, just comment out the dictResetSearchOrder() lines in ficlExec().
- </P>
- <DL>
- <DT>
- <A name="tosearch"></A><CODE>&gt;search ( wid -- )</CODE>
- </DT>
- <DD>
- Push <TT>wid</TT> onto the search order. Many of the other search order words are written in terms of the <TT>SEARCH&gt;</TT> and <TT>&gt;SEARCH</TT> primitives. This word can be defined in
- ANS Forth as follows
- </DD>
- <DD>
- <TT>: &gt;search&nbsp;&nbsp; &gt;r get-order 1+ r&gt; swap set-order ;</TT>
- </DD>
- <DT>
- <A name="searchfrom"></A><TT>search&gt;&nbsp;&nbsp; ( -- wid )</TT>
- </DT>
- <DD>
- Pop <TT>wid</TT> off the search order (can be coded in ANS Forth as&nbsp;<TT>: search&gt;&nbsp; get-order nip 1- set-order ;</TT> )
- </DD>
- <DT>
- <A name="ficlsetcurrent"></A><TT>ficl-set-current&nbsp;&nbsp; ( wid -- old-wid )</TT>
- </DT>
- <DD>
- Set wid as compile wordlist, leaving the previous compile wordlist on the stack
- </DD>
- <DT>
- <A name="ficlvocabulary"></A><TT>ficl-vocabulary&nbsp;&nbsp; ( nBins "name" -- )</TT>
- </DT>
- <DD>
- Creates a <TT>ficl-wordlist</TT> with the specified number of hash table bins, binds it to the name, and associates the semantics of <TT>vocabulary</TT> with it (replaces the top wid in the
- search order list with its own wid when executed)
- </DD>
- <DT>
- <A name="ficlwordlist"></A><TT>ficl-wordlist&nbsp;&nbsp; ( nBins -- wid )</TT>
- </DT>
- <DD>
- Creates a wordlist with the specified number of hash table bins, and leaves the address of the wordlist on the stack. A <TT>ficl-wordlist</TT> behaves exactly as a regular wordlist, but it
- may search faster depending on the number of bins chosen and the number of words it contains at search time. As implemented in ficl, a wordlist is single threaded by default. <TT>
- ficl-named-wordlist</TT> takes a name for the wordlist and creates a word that pushes the <TT>wid</TT>. This is by contrast to <TT>VOCABULARY</TT>, which also has a name, but replaces the
- top of the search order with its <TT>wid</TT>.
- </DD>
- <DT>
- <A name="ficlforgetwid"></A><TT>forget-wid&nbsp;&nbsp; ( wid -- )</TT>
- </DT>
- <DD>
- Iterates through the specified wordlist and unlinks all definitions whose xt addresses are greater than or equal to the value of <TT>HERE</TT>, the dictionary fill pointer.&nbsp;
- </DD>
- <DT>
- <A name="ficlhide"></A><TT>hide&nbsp;&nbsp; ( -- current-wid-was )</TT>
- </DT>
- <DD>
- Push the <TT>hidden</TT> wordlist onto the search order, and set it as the current compile wordlist (unsing <TT>ficl-set-current</TT>). Leaves the previous compile wordlist ID. I use this
- word to hide implementation factor words that have low reuse potential so that they don't clutter the default wordlist. To undo the effect of hide, execute&nbsp; <B><TT>previous
- set-current</TT></B>
- </DD>
- <DT>
- <A name="ficlhidden"></A><TT>hidden&nbsp;&nbsp; ( -- wid )</TT>
- </DT>
- <DD>
- Wordlist for storing implementation factors of ficl provided words. To see what's in there, try:&nbsp; <B><TT>hide words previous set-current</TT></B>
- </DD>
- <DT>
- <A name="wid-get-name"></A><TT>wid-get-name&nbsp;&nbsp; ( wid -- c-addr u )</TT>
- </DT>
- <DD>
- Ficl wordlists (2.05 and later) have a name property that can be assigned. This is used by <TT>ORDER</TT> to list the names of wordlists in the search order.&nbsp;
- </DD>
- <DT>
- <A name="wid-set-name"></A><TT>wid-set-name&nbsp;&nbsp; ( c-addr wid -- )</TT>
- </DT>
- <DD>
- Ficl wordlists (2.05 and later) have a name property that can be assigned. This is used by <TT>ORDER</TT> to list the names of wordlists in the search order. The name is assumed to be a \0
- terminated string (C style), which conveniently is how Ficl stores word names.&nbsp; See softwords/softcore.fr definition of <TT>brand-wordlist</TT>&nbsp;
- </DD>
- <DT>
- <A name="wid-set-super"></A><TT>wid-set-super&nbsp;&nbsp; ( wid -- )</TT>
- </DT>
- <DD>
- Ficl wordlists have a parent wordlist pointer that is not specified in standard Forth. Ficl initializes this pointer to NULL whenever it creates a wordlist, so it ordinarily has no effect.
- This word sets the parent pointer to the wordlist specified on the top of the stack. Ficl's implementation of <TT>SEARCH-WORDLIST</TT> will chain backward through the parent link of the
- wordlist when searching. This simplifies Ficl's object model in that the search order does not need to reflect an object's class hierarchy when searching for a method. It is possible to
- implement Ficl object syntax in strict ANS Forth, but method finders need to manipulate the search order explicitly.
- </DD>
- </DL>
- <H3>
- <A name="exuser"></A>User variables
- </H3>
- <DL>
- <DT>
- <TT>user&nbsp;&nbsp; ( -- ) name</TT>
- </DT>
- <DD>
- Create a user variable with the given name. User variables are virtual machine local. Each VM allocates a fixed amount of storage for them. You can change the maximum number of user
- variables allowed by defining FICL_USER_CELLS on your compiiler's command line. Default is 16 user cells. User variables behave like <TT>VARIABLE</TT>s in all other respects (you use @ and
- ! on them, for example). Example:
- </DD>
- <DD>
- <DL>
- <DD>
- <TT>user current-class</TT>
- </DD>
- <DD>
- <TT>0 current-class !</TT>
- </DD>
- </DL>
- </DD>
- </DL>
- <H3>
- <A name="exmisc"></A>Miscellaneous
- </H3>
- <DL>
- <DT>
- <TT>-roll&nbsp;&nbsp; ( xu xu-1 ... x0 u -- x0 xu-1 ... x1 )&nbsp;</TT>
- </DT>
- <DD>
- Rotate u+1 items on top of the stack after removing u. Rotation is in the opposite sense to <TT>ROLL</TT>
- </DD>
- </DL>
- <DL>
- <DT>
- <A name="minusrot"></A><TT>-rot&nbsp;&nbsp; ( a b c -- c a b )</TT>
- </DT>
- <DD>
- Rotate the top three stack entries, moving the top of stack to third place. I like to think of this as <TT>1<SUP>1</SUP>/<SUB>2</SUB>swap</TT> because it's good for tucking a single cell
- value behind a cell-pair (like an object).&nbsp;
- </DD>
- </DL>
- <DL>
- <DT>
- <TT>.env&nbsp;&nbsp; ( -- )</TT>
- </DT>
- <DD>
- List all environment variables of the system
- </DD>
- <DT>
- <TT>.hash&nbsp;&nbsp; ( -- )</TT>
- </DT>
- <DD>
- List hash table performance statistics of the wordlist that's first in the search order
- </DD>
- <DT>
- <TT>.ver&nbsp;&nbsp; ( -- )</TT>
- </DT>
- <DD>
- Display ficl version ID
- </DD>
- <DT>
- <TT>&gt;name&nbsp;&nbsp; ( xt -- c-addr u )</TT>
- </DT>
- <DD>
- Convert a word's execution token into the address and length of its name
- </DD>
- <DT>
- <TT>body&gt;&nbsp;&nbsp; ( a-addr -- xt )</TT>
- </DT>
- <DD>
- Reverses the effect of <TT>CORE</TT> word <TT>&gt;body</TT> (converts a parameter field address to an execution token)
- </DD>
- <DT>
- <TT>compile-only</TT>
- </DT>
- <DD>
- Mark the most recently defined word as being executable only while in compile state. Many <TT>immediate</TT> words have this property.
- </DD>
- <DT>
- <TT>empty&nbsp;&nbsp; ( -- )</TT>&nbsp;
- </DT>
- <DD>
- Empty the parameter stack
- </DD>
- <DT>
- <TT>endif</TT>
- </DT>
- <DD>
- Synonym for <TT>THEN</TT>
- </DD>
- <DT>
- <A name="last-word"></A><TT>last-word&nbsp;&nbsp; ( -- xt )</TT>
- </DT>
- <DD>
- Pushes the xt address of the most recently defined word. This applies to colon definitions, constants, variables, and words that use <TT>create</TT>. You can print the name of the most
- recently defined word with&nbsp;
- </DD>
- <DD>
- <B><TT>last-word &gt;name type</TT>&nbsp;</B>
- </DD>
- <DT>
- <TT>parse-word&nbsp;&nbsp; ( &lt;spaces&gt;name -- c-addr u )</TT>
- </DT>
- <DD>
- Skip leading spaces and parse name delimited by a space. c-addr is the address within the input buffer and u is the length of the selected string. If the parse area is empty, the resulting
- string has a zero length. (From the Standard)
- </DD>
- <DT>
- <A name="qfetch"></A><TT>q@&nbsp;&nbsp; ( addr -- x )</TT>
- </DT>
- <DD>
- Fetch a 32 bit quantity from the specified address
- </DD>
- <DT>
- <A name="qbang"></A><TT>q!&nbsp;&nbsp; ( x addr -- )</TT>
- </DT>
- <DD>
- Store a 32 bit quantity to the specified address&nbsp;
- </DD>
- <DT>
- <TT>w@&nbsp;&nbsp; ( addr -- x )</TT>
- </DT>
- <DD>
- Fetch a 16 bit quantity from the specified address
- </DD>
- <DT>
- <TT>w!&nbsp;&nbsp; ( x addr -- )</TT>
- </DT>
- <DD>
- Store a 16 bit quantity to the specified address (the low 16 bits of the given value)
- </DD>
- <DT>
- <A name="xdot"></A><TT>x.&nbsp;&nbsp; ( x -- )</TT>
- </DT>
- <DD>
- Pop and display the value in hex format, regardless of the current value of <TT>BASE</TT>
- </DD>
- </DL>
- <H3>
- <A name="exficlwin"></A>Extra words defined in testmain.c (Win32 and POSIX versions)
- </H3>
- <DL>
- <DT>
- <TT>break&nbsp;&nbsp; ( -- )</TT>
- </DT>
- <DD>
- Does nothing - just a handy place to set a debugger breakpoint
- </DD>
- <DT>
- <TT>cd&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( "directory-name&lt;newline&gt;" -- )</TT>
- </DT>
- <DD>
- Executes the Win32 chdir() function, changing the program's logged directory.
- </DD>
- <DT>
- <A name="clock"></A><TT>clock&nbsp;&nbsp; ( -- now )</TT>
- </DT>
- <DD>
- Wrapper for the ANSI C clock() function. Returns the number of clock ticks elapsed since process start.
- </DD>
- <DT>
- <A name="clockspersec"></A><TT>clocks/sec&nbsp;&nbsp; ( -- clocks_per_sec )</TT>
- </DT>
- <DD>
- Pushes the number of ticks in a second as returned by <TT>clock</TT>
- </DD>
- <DT>
- <A name="ficlload"></A><TT>load&nbsp;&nbsp;&nbsp; ( "filename&lt;newline&gt;" -- )</TT>
- </DT>
- <DD>
- Opens the Forth source file specified and loads it one line at a time, like <TT>INCLUDED (FILE)</TT>
- </DD>
- <DT>
- <TT>pwd&nbsp;&nbsp;&nbsp;&nbsp; ( -- )</TT>
- </DT>
- <DD>
- Prints the current working directory as set by <TT>cd</TT>
- </DD>
- <DT>
- <TT>system&nbsp; ( "command&lt;newline&gt;" -- )</TT>
- </DT>
- <DD>
- Issues a command to a shell; implemented with the Win32 system() call.
- </DD>
- <DT>
- <TT>spewhash&nbsp;&nbsp; ( "filename&lt;newline&gt;" -- )</TT>
- </DT>
- <DD>
- Dumps all threads of the current compilation wordlist to the specified text file. This was useful when I thought there might be some point in attempting to optimize the hash function. I no
- longer harbor those illusions.
- </DD>
- </DL>
- <H3>
- Words defined in FiclWin only
- </H3>
- <DL>
- <DT>
- <TT>!oreg&nbsp;&nbsp; ( c -- )</TT>
- </DT>
- <DD>
- Set the value of the simulated LED register as specified (0..255)
- </DD>
- <DT>
- <TT>@ireg&nbsp;&nbsp; ( -- c )</TT>
- </DT>
- <DD>
- Gets the value of the simulated switch block (0..255)
- </DD>
- <DT>
- <TT>!dac&nbsp;&nbsp;&nbsp; ( c -- )</TT>
- </DT>
- <DD>
- Sets the value of the bargraph control as specified. Valid values range from 0..255
- </DD>
- <DT>
- <TT>@adc&nbsp;&nbsp;&nbsp; ( -- c )</TT>
- </DT>
- <DD>
- Fetches the current position of the slider control. Range is 0..255
- </DD>
- <DT>
- <TT>status"&nbsp;&nbsp; ( "ccc&lt;quote&gt;" -- )</TT>
- </DT>
- <DD>
- Set the mainframe window's status line to the text specified, up to the first trailing quote character.
- </DD>
- <DT>
- <A name="ficlms"></A><TT><A href="http://www.taygeta.com/forth/dpans10.htm#10.6.2.1905">ms</A>&nbsp;&nbsp; ( u -- )</TT>
- </DT>
- <DD>
- Causes the running virtual machine to sleep() for the number of milliseconds specified by the top-of-stack value.
- </DD>
- </DL>
- <HR>
- <H2>
- <A name="ansinfo"></A>ANS Required Information
- </H2>
- <B>ANS Forth System</B><BR>
- <B>Providing names from the Core Extensions word set&nbsp;</B><BR>
- <B>Providing the Exception word set</B><BR>
- <B>Providing names from the Exception Extensions word set</B><BR>
- <B>Providing the Locals word set&nbsp;</B><BR>
- <B>Providing the Locals Extensions word set&nbsp;</B><BR>
- <B>Providing the Memory Allocation word set</B><BR>
- <B>Providing the Programming-Tools word set</B><BR>
- <B>Providing names from the Programming-Tools Extensions word set</B><BR>
- <B>Providing the Search-Order word set</B><BR>
- <B>Providing the Search-Order Extensions word set</B>
- <H3>
- Implementation-defined Options
- </H3>
- The implementation-defined items in the following list represent characteristics and choices left to the discretion of the implementor, provided that the requirements of the Standard are met. A
- system shall document the values for, or behaviors of, each item.&nbsp;
- <UL>
- <LI>
- <B>aligned address requirements (3.1.3.3 Addresses);</B>&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">System dependent. You can change the default address alignment by defining FICL_ALIGN on your compiler's command line. The default value is set to 2 in sysdep.h. This
- causes dictionary entries and <TT>ALIGN</TT> and <TT>ALIGNED</TT> to align on 4 byte boundaries. To align on <B>2<SUP>n</SUP></B> byte boundaries, set FICL_ALIGN to <B>n</B>.&nbsp;</FONT>
- </LI>
- <LI>
- <B>behavior of 6.1.1320 EMIT for non-graphic characters</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Depends on target system, C runtime library, and your implementation of ficlTextOut().</FONT>
- </LI>
- <LI>
- <B>character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">None implemented in the versions supplied in words.c. Because ficlExec() is supplied a text buffer externally, it's up to your system to define how that buffer will
- be obtained.</FONT>
- </LI>
- <LI>
- <B>character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750 KEY)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Depends on target system and implementation of ficlTextOut()</FONT>
- </LI>
- <LI>
- <B>character-aligned address requirements (3.1.3.3 Addresses)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl characters are one byte each. There are no alignment requirements.</FONT>
- </LI>
- <LI>
- <B>character-set-extensions matching characteristics (3.4.2 Finding definition n<FONT color="#000000">ames)</FONT></B><FONT color="#000000">;&nbsp;</FONT>
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">No special processing is performed on characters beyond case-folding. Therefore, extended characters will not match their unaccented counterparts.</FONT>
- </LI>
- <LI>
- <B>conditions under which control characters match a space delimiter (3.4.1.1 Delimiters)</B>;<FONT color="#FF6666">&nbsp;</FONT>
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl uses the Standard C function isspace() to distinguish space characters. The rest is up to your library vendor.</FONT>
- </LI>
- <LI>
- <B>format of the control-flow stack (3.2.3.2 Control-flow stack)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Uses the data stack</FONT>
- </LI>
- <LI>
- <B>conversion of digits larger than thirty-five (3.2.1.2 Digit conversion)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">The maximum supported value of <TT>BASE</TT> is 36. Ficl will assertion fail in function ltoa of vm.c if the base is found to be larger than 36 or smaller than 2.
- There will be no effect if NDEBUG is defined</FONT>, however, other than possibly unexpected behavior.&nbsp;
- </LI>
- <LI>
- <B>display after input terminates in 6.1.0695 ACCEPT and 6.2.1390 EXPECT</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Target system dependent</FONT>
- </LI>
- <LI>
- <B>exception abort sequence (as in 6.1.0680 ABORT")</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Does <TT>ABORT</TT></FONT>
- </LI>
- <LI>
- <B>input line terminator (3.2.4.1 User input device)</B>;<FONT color="#FF0000">&nbsp;</FONT>
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Target system dependent (implementation of outer loop that calls ficlExec)</FONT>
- </LI>
- <LI>
- <B>maximum size of a counted string, in characters (3.1.3.4 Counted strings, 6.1.2450 WORD)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">255</FONT>
- </LI>
- <LI>
- <B>maximum size of a parsed string (3.4.1 Parsing)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- Limited by available memory and the maximum unsigned value that can fit in a CELL (2<SUP>32</SUP>-1).&nbsp;
- </LI>
- <LI>
- <B>maximum size of a definition name, in characters (3.3.1.2 Definition names)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl stores the first 31 characters of a definition name.</FONT>
- </LI>
- <LI>
- <B>maximum string length for 6.1.1345 ENVIRONMENT?, in characters</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Same as maximum definition name length</FONT>
- </LI>
- <LI>
- <B>method of selecting 3.2.4.1 User input device</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- None supported. This is up to the target system&nbsp;
- </LI>
- <LI>
- <B>method of selecting 3.2.4.2 User output device</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- None supported. This is up to the target system&nbsp;
- </LI>
- <LI>
- <B>methods of dictionary compilation (3.3 The Forth dictionary)</B>;&nbsp;
- </LI>
- <LI>
- <B>number of bits in one address unit (3.1.3.3 Addresses)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Target system dependent. Ficl generally supports processors that can address 8 bit quantities, but there is no dependency that I'm aware of.</FONT>
- </LI>
- <LI>
- <B>number representation and arithmetic (3.2.1.1 Internal number representation)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- System dependent. Ficl represents a CELL internally as a union that can hold INT32 (a signed 32 bit scalar value), UNS32 (32 bits unsigned), and an untyped pointer. No specific byte
- ordering is assumed.&nbsp;
- </LI>
- <LI>
- <B>ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types, 3.1.4 Cell-pair types)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- Assuming a 32 bit implementation, range for signed single-cell values is -2<SUP>31</SUP>..2<SUP>31</SUP>-1. Range for unsigned single cell values is 0..2<SUP>32</SUP>-1. Range for signed
- double-cell values is -2<SUP>63</SUP>..2<SUP>63</SUP>-1. Range for unsigned single cell values is 0..2<SUP>64</SUP>-1.&nbsp;
- </LI>
- <LI>
- <B>read-only data-space regions (3.3.3 Data space)</B>;
- </LI>
- <LI>
- <BR>
- None&nbsp;
- </LI>
- <LI>
- <B>size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient regions)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- Default is 255. Depends on the setting of nPAD in ficl.h.&nbsp;
- </LI>
- <LI>
- <B>size of one cell in address units (3.1.3 Single-cell types)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">System dependent, generally four.</FONT>
- </LI>
- <LI>
- <B>size of one character in address units (3.1.2 Character types)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">System dependent, generally one.</FONT>
- </LI>
- <LI>
- <B>size of the keyboard terminal input buffer (3.3.3.5 Input buffers)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">This buffer is supplied by the host program. Ficl imposes no practical limit.</FONT>
- </LI>
- <LI>
- <B>size of the pictured numeric output string buffer (3.3.3.6 Other transient regions)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- Default is 255 characters. Depends on the setting of nPAD in ficl.h.&nbsp;
- </LI>
- <LI>
- <B>size of the scratch area whose address is returned by 6.2.2000 PAD (3.3.3.6 Other transient regions)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- Not presently supported&nbsp;
- </LI>
- <LI>
- <B>system case-sensitivity characteristics (3.4.2 Finding definition names)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl is not case sensitive</FONT>
- </LI>
- <LI>
- <B>system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">"ok&gt;"</FONT>
- </LI>
- <LI>
- <B>type of division rounding (3.2.2.1 Integer division, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Symmetric</FONT>
- </LI>
- <LI>
- <B>values of 6.1.2250 STATE when true</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">One (no others)</FONT>
- </LI>
- <LI>
- <B>values returned after arithmetic overflow (3.2.2.2 Other integer operations)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- System dependent. Ficl makes no special checks for overflow.&nbsp;
- </LI>
- <LI>
- <B>whether the current definition can be found after 6.1.1250 DOES&gt; (6.1.0450 :)</B>.&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">No. Definitions are unsmudged after ; only, and only then if no control structure matching problems have been detected.</FONT>
- </LI>
- </UL>
- <H3>
- Ambiguous Conditions
- </H3>
- A system shall document the system action taken upon each of the general or specific ambiguous conditions identified in this Standard. See 3.4.4 Possible actions on an ambiguous
- condition.&nbsp;
- <P>
- The following general ambiguous conditions could occur because of a combination of factors:&nbsp;
- </P>
- <UL>
- <LI>
- <B>a name is neither a valid definition name nor a valid number during text interpretation (3.4 The Forth text interpreter)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl does <TT>ABORT</TT> and prints the name followed by " not found".</FONT>
- </LI>
- <LI>
- <B>a definition name exceeded the maximum length allowed (3.3.1.2 Definition names)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl stores the first 31 characters of the definition name, and uses all characters of the name in computing its hash code. The actual length of the name, up to 255
- characters, is stored in the definition's length field.</FONT>
- </LI>
- <LI>
- <B>addressing a region not listed in 3.3.3 Data Space</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">No problem: all addresses in ficl are absolute. You can reach any 32 bit address in Ficl's address space.</FONT>
- </LI>
- <LI>
- <B>argument type incompatible with specified input parameter, e.g., passing a flag to a word expecting an n (3.1 Data types)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl makes no check for argument type compatibility. Effects of a mismatch vary widely depending on the specific problem and operands.</FONT>
- </LI>
- <LI>
- <B>attempting to obtain the execution token, (e.g., with 6.1.0070 ', 6.1.1550 FIND, etc.) of a definition with undefined interpretation semantics</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl returns a valid token, but the result of executing that token while interpreting may be undesirable.</FONT>
- </LI>
- <LI>
- <B>dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 8.6.1.1820 M*/)</B>;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Results are target procesor dependent. Generally, Ficl makes no check for divide-by-zero. The target processor will probably throw an exception.</FONT>
- </LI>
- <LI>
- <B>insufficient data-stack space or return-stack space (stack overflow)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">With FICL_ROBUST (sysdep.h) set &gt;= 2, most parameter stack operations are checked for underflow and overflow. Ficl does not check the return stack.</FONT>
- </LI>
- <LI>
- <B>insufficient space for loop-control parameters</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">No check - Evil results.</FONT>
- </LI>
- <LI>
- <B>insufficient space in the dictionary</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl generates an error message if the dictionary is too full to create a definition header. It checks <TT>ALLOT</TT> as well, but it is possible to make an unchecked
- allocation request that overflows the dictionary.</FONT>
- </LI>
- <LI>
- <B>interpreting a word with undefined interpretation semantics</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl protects all ANS Forth words with undefined interpretation semantics from being executed while in interpret state. It is possible to defeat this protection using
- ' (tick) and <TT>EXECUTE</TT>, though.</FONT>
- </LI>
- <LI>
- <B>modifying the contents of the input buffer or a string literal (3.3.3.4 Text-literal regions, 3.3.3.5 Input buffers)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Varies depending on the nature of the buffer. The input buffer is supplied by ficl's host function, and may reside in read-only memory. If so, writing the input
- buffer can ganerate an exception. String literals are stored in the dictionary, and are writable.</FONT>
- </LI>
- <LI>
- <B>overflow of a pictured numeric output string</B>;
- </LI>
- <LI>
- <BR>
- In the unlikely event you are able to construct a pictured numeric string of more than 255 characters, the system will be corrupted unpredictably. The buffer area that holds pictured
- numeric output is at the end of the virtual machine. Whatever is mapped after the offending VM in memory will be trashed, along with the heap structures that contain it.&nbsp;
- </LI>
- <LI>
- <B>parsed string overflow</B>;
- </LI>
- <LI>
- <BR>
- Ficl does not copy parsed strings unless asked to. Ordinarily, a string parsed from the input buffer during normal interpretation is left in-place, so there is no possibility of overflow.
- If you ask to parse a string into the dictionary, as in <TT>SLITERAL</TT>, you need to have enough room for the string, otherwise bad things may happen. This is not usually a problem.&nbsp;
- </LI>
- <LI>
- <B>producing a result out of range, e.g., multiplication (using *) results in a value too big to be represented by a single-cell integer (6.1.0090 *, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570
- &gt;NUMBER, 6.1.1561 FM/MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 6.2.0970 CONVERT, 8.6.1.1820 M*/)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Value will be truncated</FONT>
- </LI>
- <LI>
- <B>reading from an empty data stack or return stack (stack underflow)</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Most stack underflows are detected and prevented if FICL_ROBUST (sysdep.h) is set to 2 or greater. Otherwise, the stack pointer and size are likely to be
- trashed.</FONT>
- </LI>
- <LI>
- <B>unexpected end of input buffer, resulting in an attempt to use a zero-length string as a name</B>;&nbsp;
- </LI>
- <LI>
- <BR>
- <FONT color="#000000">Ficl returns for a new input buffer until a non-empty one is supplied.</FONT>
- </LI>
- </UL>
- The following specific ambiguous conditions are noted in the glossary entries of the relevant words:&nbsp;
- <UL>
- <LI>
- <B>&gt;IN greater than size of input buffer (3.4.1 Parsing)</B>
- </LI>
- <LI>
- <BR>
- Bad Things occur - unpredictable bacause the input buffer is supplied by the host program's outer loop.&nbsp;
- </LI>
- <LI>
- <B>6.1.2120 RECURSE appears after 6.1.1250 DOES&gt;</B>
- </LI>
- <LI>
- <BR>
- It finds the address of the definition before <TT>DOES&gt;</TT>
- </LI>
- <LI>
- <B>argument input source different than current input source for 6.2.2148 RESTORE-INPUT</B>
- </LI>
- <LI>
- <BR>
- Not implemented&nbsp;
- </LI>
- <LI>
- <B>data space containing definitions is de-allocated (3.3.3.2 Contiguous regions)</B>
- </LI>
- <LI>
- <BR>
- This is OK until the cells are overwritten with something else. The dictionary maintains a hash table, and the table must be updated in order to de-allocate words without corruption.&nbsp;
- </LI>
- <LI>
- <B>data space read/write with incorrect alignment (3.3.3.1 Address alignment)</B>
- </LI>
- <LI>
- <BR>
- Target processor dependent. Consequences include: none (Intel), address error exception (68K).&nbsp;
- </LI>
- <LI>
- <B>data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860 C,)</B>
- </LI>
- <LI>
- <BR>
- See above on data space read/write alignment&nbsp;
- </LI>
- <LI>
- <B>less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)</B>
- </LI>
- <LI>
- <BR>
- Ficl detects a stack underflow and reports it, executing <TT>ABORT,</TT> as long as FICL_ROBUST is two or larger.&nbsp;
- </LI>
- <LI>
- <B>loop-control parameters not available ( 6.1.0140 +LOOP, 6.1.1680 I, 6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)</B>
- </LI>
- <LI>
- <BR>
- Loop initiation words are responsible for checking the stack and guaranteeing that the control parameters are pushed. Any underflows will be detected early if FICL_ROBUST is set to two or
- greater. Note however that Ficl only checks for return stack underflows at the end of each line of text.&nbsp;
- </LI>
- <LI>
- <B>most recent definition does not have a name (6.1.1710 IMMEDIATE)</B>
- </LI>
- <LI>
- <BR>
- No problem.&nbsp;
- </LI>
- <LI>
- <B>name not defined by 6.2.2405 VALUE used by 6.2.2295 TO</B>
- </LI>
- <LI>
- <BR>
- Ficl's version of <TT>TO</TT> works correctly with <TT>VALUE</TT>s, <TT>CONSTANT</TT>s and <TT>VARIABLE</TT>s.&nbsp;
- </LI>
- <LI>
- <B>name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['], 6.2.2530 [COMPILE])</B>
- </LI>
- <LI>
- <BR>
- Ficl prints an error message and does <TT>ABORT</TT>
- </LI>
- <LI>
- <B>parameters are not of the same type (6.1.1240 DO, 6.2.0620 ?DO, 6.2.2440 WITHIN)</B>
- </LI>
- <LI>
- <BR>
- No check. Results vary depending on the specific problem.&nbsp;
- </LI>
- <LI>
- <B>6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO</B>
- </LI>
- <LI>
- <BR>
- The word is postponed correctly.&nbsp;
- </LI>
- <LI>
- <B>string longer than a counted string returned by 6.1.2450 WORD</B>
- </LI>
- <LI>
- <BR>
- Ficl stores the first FICL_STRING_MAX-1 chars in the destination buffer. (The extra character is the trailing space required by the standard. Yuck.)&nbsp;
- </LI>
- <LI>
- <B>u greater than or equal to the number of bits in a cell (6.1.1805 LSHIFT, 6.1.2162 RSHIFT)</B>
- </LI>
- <LI>
- <BR>
- Depends on target process or and C runtime library implementations of the &lt;&lt; and &gt;&gt; operators on unsigned values. For I386, the processor appears to shift modulo the number of
- bits in a cell.&nbsp;
- </LI>
- <LI>
- <B>word not defined via 6.1.1000 CREATE (6.1.0550 &gt;BODY, 6.1.1250 DOES&gt;)</B>
- </LI>
- <LI>
- <BR>
- <B>words improperly used outside 6.1.0490 &lt;# and 6.1.0040 #&gt; (6.1.0030 #, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)</B><BR>
- Don't. <TT>CREATE</TT> reserves a field in words it builds for <TT>DOES&gt;</TT>to fill in. If you use <TT>DOES&gt;</TT> on a word not made by <TT>CREATE</TT>, it will overwrite the first
- cell of its parameter area. That's probably not what you want. Likewise, pictured numeric words assume that there is a string under construction in the VM's scratch buffer. If that's not
- the case, results may be unpleasant.
- </LI>
- </UL>
- <H3>
- Locals Implementation-defined options
- </H3>
- <UL>
- <LI>
- <B>maximum number of locals in a definition (13.3.3 Processing locals, 13.6.2.1795 LOCALS|)</B>
- </LI>
- <LI>
- <BR>
- Default is 16. Change by redefining FICL_MAX_LOCALS, defined in sysdep.h
- </LI>
- </UL>
- <H3>
- Locals Ambiguous conditions
- </H3>
- <UL>
- <LI>
- <B>executing a named local while in interpretation state (13.6.1.0086 (LOCAL))</B>
- </LI>
- <LI>
- <BR>
- Locals can be found in interpretation state while in the context of a definition under construction. Under these circumstances, locals behave correctly. Locals are not visible at all
- outside the scope of a definition.&nbsp;
- </LI>
- <LI>
- <B>name not defined by VALUE or LOCAL (13.6.1.2295 TO)</B>
- </LI>
- <LI>
- <BR>
- See the CORE ambiguous conditions, above (no change)
- </LI>
- </UL>
- <H3>
- Programming Tools Implementation-defined options
- </H3>
- <UL>
- <LI>
- <B>source and format of display by 15.6.1.2194 SEE</B>
- </LI>
- <LI>
- <BR>
- SEE de-compiles definitions from the dictionary. Because Ficl words are threaded by their header addresses, it is very straightforward to print the name and other characteristics of words
- in a definition. Primitives are so noted. Colon definitions are decompiled, but branch target labels are not reconstructed. Literals and string literals are so noted, and their contents
- displayed.
- </LI>
- </UL>
- <H3>
- Search Order Implementation-defined options
- </H3>
- <UL>
- <LI>
- <B>maximum number of word lists in the search order (16.3.3 Finding definition names, 16.6.1.2197 SET-ORDER)</B>&nbsp;
- </LI>
- <LI>
- <BR>
- Defaults to 16. Can be changed by redefining FICL_DEFAULT_VOCS, declared in sysdep.h&nbsp;
- </LI>
- <LI>
- <B>minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)</B>&nbsp;
- </LI>
- <LI>
- <BR>
- Equivalent to <TT>FORTH-WORDLIST 1 SET-ORDER</TT>
- </LI>
- </UL>
- <H3>
- Search Order Ambiguous conditions
- </H3>
- <UL>
- <LI>
- <B>changing the compilation word list (16.3.3 Finding definition names)</B>
- </LI>
- <LI>
- <BR>
- Ficl stores a link to the current definition independently of the compile wordlist while it is being defined, and links it into the compile wordlist only after the definition completes
- successfully. Changing the compile wordlist mid-definition will cause the definition to link into the <I>new</I> compile wordlist.&nbsp;
- </LI>
- <LI>
- <B>search order empty (16.6.2.2037 PREVIOUS)</B>
- </LI>
- <LI>
- <BR>
- Ficl prints an error message if the search order underflows, and resets the order to its default state.&nbsp;
- </LI>
- <LI>
- <B>too many word lists in search order (16.6.2.0715 ALSO)</B>
- </LI>
- <LI>
- <BR>
- Ficl prints an error message if the search order overflows, and resets the order to its default state.
- </LI>
- </UL>
- </DIV>
- </BODY>
-</HTML>
+</b>
+<p>
+
+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
+<a href="mailto:john_sadler@alum.mit.edu">send me email</a>.
+<p>
+
+
+<h2><a name="features">Ficl Features</a></h2>
+
+<ul>
+
+<li>
+Simple to integrate into existing systems: the sample
+implementation requires three Ficl function calls (see the example
+program in <b>main.c</b>).
+
+<li>
+Written in ANSI C for portability.
+
+<li>
+Standard: Implements the ANS Forth CORE word set, part of the
+CORE EXT word set, SEARCH and SEARCH EXT, TOOLS and part of TOOLS EXT,
+LOCAL and LOCAL EXT, EXCEPTION, MEMORY, and various extras.
+
+<li>
+Extensible: you can export code written in Forth, C, or ASM in a
+straightforward way. Ficl provides open facilities for extending the
+language in an application specific way. You can even add new
+control structures (not surprising if you're familiar with Forth)
+
+<li>
+Ficl and C/C++ can interact in two ways: Ficl can wrap C code,
+and C functions can invoke Ficl code.
+
+<li>
+Ficl code is thread safe and re-entrant: your program can have one or more
+Ficl "systems", and each "system" can have one or Ficl virtual machines.
+Each Ficl virtual machine has an otherwise complete state, and each can
+be bound to a separate I/O channel (or none at all).
+An optional function called ficlLockDictionary() can control
+exclusive dictionary access. This function is stubbed out by
+default (See FICL_MULTITHREAD in sysdep.h). As long as there is only
+one "session" that can compile words into the dictionary, you do not
+need exclusive dictionary access for multithreading.
+<b>Note</b>:
+while the code is re-entrant, there are still restrictions on how you
+can use it safely in a multithreaded system. Specifically, the VM
+itself maintains state, so you generally need a VM per thread in a
+multithreaded system. If interrupt service routines make calls into Ficl
+code that alters VM state, then these generally need their
+own VM as well. Alternatively, you could provide a mutual exclusion
+mechanism to serialize access to a VM from multiple threads.
+
+<li>
+ROMable: Ficl is designed to work in RAM based and ROM code / RAM
+data environments. It does require somewhat more memory than a pure ROM
+implementation because it builds its system dictionary in RAM
+at startup time.
+
+<li>
+Written in ANSI C to be as simple as I can make it to understand,
+support, debug, and port. Compiles without complaint at <code>/Az /W4</code> (require
+ANSI C, max. warnings) under Microsoft Visual C++, and <code>-ansi</code>
+under GCC. Ports to several other toolchains and operating systems
+(notably FreeBSD and Linux flavors) exist.
+
+<li> Does full 32 bit math (but you need to implement two mixed
+precision math primitives (see sysdep.c)) </li>
+
+</ul>
+
+<hr>
+
+<h2><a name="porting">Porting Ficl</a></h2>
+
+To install Ficl on your target system, you need an ANSI C compiler and
+its runtime library. Inspect the system dependent macros and functions
+in <b>sysdep.h</tt> and <tt>sysdep.c</tt> and edit them to suit
+your system. For example, <tt>INT16</tt> is a <tt>short</tt> on some
+compilers and an <tt>int</tt> on others. Check the default <tt>CELL</tt>
+alignment controlled by <tt> FICL_ALIGN</tt>. If necessary, add new
+definitions of <tt>ficlMalloc, ficlFree, ficlRealloc</tt>, and <tt>ficlTextOut</tt>
+to work with your operating system. Finally, use <tt>testmain.c</tt> as
+a guide to installing the ficl system and one or more virtual machines
+into your code. You do not need to include <tt>testmain.c</tt> in your
+build.
+<p>
+Note: ficlLockDictionary can be left unimplemented in most
+multithreaded implementations - it's only necessary if you expect to
+have more than one thread modifying the dictionary at the same
+time. If you do decide to implement it, make sure calls to
+ficlLockDictionary can nest properly (see the comments in sysdep.h). You
+need to keep count of nested locks and unlocks and do the right
+thing.
+<p>
+
+Feel free to stub out the double precision math functions (which are
+presently implemented as inline assembly because it's so easy on many 32
+bit processors) with kludge code that only goes to 32 bit
+precision. In most applications, you won't notice the difference. If
+you're doing a lot of number crunching, consider implementing them
+correctly.
+
+
+<h3>Build Controls</h3>
+
+The file sysdep.h contains default values for build controls. Most of
+these are written such that if you define them on the compiler command
+line, the defaults are overridden. I suggest you take the defaults
+on everything below the "build controls" section until you're confident
+of your port. Beware of declaring too small a dictionary, for example.
+You need about 3200 cells for a full system, about 2000 if you
+strip out most of the "soft" words.
+
+<h3>Softcore</h3>
+Many words from all the supported wordsets are written in Forth, and
+stored as a big string that Ficl compiles when it starts. The sources
+for all of these words are in directory <b>softcore</b>. There is a
+.bat file (softcore.bat) and a PERL 5 script (softcore.pl) that convert
+Forth files into the file softcore.c, so softcore.c is really dependent
+on the Forth sources. This is not reflected in the Visual C++ project
+database. For the time being, it's a manual step. You can edit
+<b>make.bat</b> to change the list of files that contribute to
+<b>softcore.c</b>.
+
+<h3>To-Do List (target system dependent words)</h3>
+
+<ul>
+
+<li>
+Unimplemented system dependent <tt>CORE</tt> word: <tt>KEY</tt>
+(implement this yourself if you need it)
+
+<li>
+Kludged <tt>CORE</tt> word: <tt>ACCEPT</tt> (implement this
+better if you need to)
+
+</ul>
+
+<h2><a name="api">Application Programming Interface</a></h2>
+
+The following is a partial listing of functions that interface your
+system or program to Ficl. For a complete listing, see <b>ficl.h</b>
+(which is heavily commented). For examples, see <b>main.c</b> and the
+FiclWin sources (<a href="#download">below</a>).
+<dl>
+ <dt> <b>FICL_SYSTEM *ficlInitSystem(int nDictCells)</b> </dt>
+ <dd> Initializes Ficl's shared system data structures, and creates the
+dictionary allocating the specified number of CELLs from the heap (by a
+call to ficlMalloc) </dd>
+ <dt> <b>void ficlTermSystem(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Reclaims memory allocated for the ficl system including all
+dictionaries and all virtual machines created by vmCreate. Any uses of
+the memory allocation words (allocate and resize) are your
+problem. </dd>
+ <dt> <b>int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code,
+char flags)</b> </dt>
+ <dd> Create a primitive word in ficl's main dictionary with the given
+name, code pointer, and properties (immediate, compile only, etc) as
+described by the flags (see ficl.h for flag descriptions of
+the form FW_XXXX) </dd>
+ <dt> <b>int ficlExec(FICL_VM *pVM, char *text)</b> </dt>
+ <dd> Feed the specified C string ('\0' terminated) to the given
+virtual machine for evaluation. Returns various exception codes (VM_XXXX
+in ficl.h) to indicate the reason for returning. Normal exit
+condition is VM_OUTOFTEXT, indicating that the VM consumed the string
+successfully and is back for more. ficlExec calls can be nested, and
+the function itself is re-entrant, but note that a VM is
+static, so you have to take reasonable precautions (for example, use one
+VM per thread in a multithreaded system if you want multiple threads to
+be able to execute commands). </dd>
+ <dt> <b>int ficlExecC(FICL_VM *pVM, char *text, int nChars)</b> </dt>
+ <dd> Same as ficlExec, but takes a count indicating the length of the
+supplied string. Setting nChars to -1 is equivalent to ficlExec (expects
+'\0' termination). </dd>
+ <dt> <b>int ficlExecXT(FICL_VM *pVM, FICL_WORD *pFW)</b> </dt>
+ <dd> Same as ficlExec, but takes a pointer to a FICL_WORD instead of a
+string. Executes the word and returns after it has finished. If
+executing the word results in an exception, this function will
+re-throw the same code if it is nested under another ficlExec family
+function, or return the exception code directly if not. This function
+is useful if you need to execute the same word repeatedly -
+you save the dictionary search and outer interpreter overhead. </dd>
+ <dt> <b>void ficlFreeVM(FICL_VM *pVM)</b> </dt>
+ <dd> Removes the VM in question from the system VM list and deletes
+the&nbsp; memory allocated to it. This is an optional call, since
+ficlTermSystem will do this cleanup for you. This function is
+handy if you're going to do a lot of dynamic creation of VMs. </dd>
+ <dt> <b>FICL_VM *ficlNewVM(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Create, initialize, and return a VM from the heap using
+ficlMalloc. Links the VM into the system VM list for later reclamation
+by ficlTermSystem. </dd>
+ <dt> <b>FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name)</b> </dt>
+ <dd> Returns the address (also known as an XT in this case) of the
+specified word in the main dictionary. If not found, returns NULL. The
+address can be used in a call to ficlExecXT. </dd>
+ <dt> <b>FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the main system dictionary, or NULL if the
+system is uninitialized. </dd>
+ <dt> <b>FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the environment dictionary. This dictionary
+stores information that describes this implementation as required by the
+Standard. </dd>
+ <dt> <b>void ficlSetEnv(FICL_SYSTEM *pSys, char *name, UNS32 value)</b> </dt>
+ <dd> Enters a new constant into the environment dictionary, with the
+specified name and value. </dd>
+ <dt> <b>void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, UNS32 hi,
+UNS32 lo)</b> </dt>
+ <dd> Enters a new double-cell constant into the environment dictionary
+with the specified name and value. </dd>
+ <dt> <b>FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the locals dictionary. This function is
+defined only if FICL_WANT_LOCALS is #defined as non-zero (see sysdep.h).
+The locals dictionary is the symbol table for <a href="ficl_loc.html">local
+variables</a>. </dd>
+ <dt> <b>void ficlCompileCore(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Defined in words.c, this function builds ficl's primitives.&nbsp;
+ </dd>
+ <dt> <b>void ficlCompileSoftCore(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Defined in softcore.c, this function builds ANS required words
+and ficl extras by evaluating a text string (think of it as a memory
+mapped file ;-) ). The string itself is built from files in
+the softwords directory by PERL script softcore.pl.&nbsp; </dd>
+</dl>
+<hr>
+<table border="0" cellspacing="5" cols="2">
+ <tbody>
+ <tr>
+ <td colspan="2">
+ <h2> <a name="manifest"></a>Ficl Source Files </h2>
+ </td>
+ </tr>
+ <tr>
+ <td> <b>ficl.h</b> </td>
+ <td> Declares most public functions and all data structures.
+Includes sysdep.h and math.h </td>
+ </tr>
+ <tr>
+ <td> <b>sysdep.h</b> </td>
+ <td> Declares system dependent functions and contains build
+control macros. Edit this file to port to another system. </td>
+ </tr>
+ <tr>
+ <td> <b>math.h</b> </td>
+ <td> Declares functions for 64 bit math </td>
+ </tr>
+ <tr>
+ <td> <b>dict.c</b> </td>
+ <td> Dictionary </td>
+ </tr>
+ <tr>
+ <td> <b>ficl.c</b> </td>
+ <td> System initialization, termination, and ficlExec </td>
+ </tr>
+ <tr>
+ <td> <b>float.c</b> </td>
+ <td> Adds precompiled definitions from the optional FLOAT word
+set. Most of the file is conditioned on FICL_WANT_FLOAT </td>
+ </tr>
+ <tr>
+ <td> <b>math64.c</b> </td>
+ <td> Implementation of 64 bit math words (except the two unsigned
+primitives declared in sysdep.h and implemented in sysdep.c) </td>
+ </tr>
+ <tr>
+ <td> <b>prefix.c</b> </td>
+ <td> The optional prefix parse step (conditioned on
+FICL_EXTENDED_PREFIX). This parse step handles numeric constructs like
+0xa100, for example. See the release notes for more on parse steps. </td>
+ </tr>
+ <tr>
+ <td> <b>search.c</b> </td>
+ <td> Contains C implementations of several of the SEARCH and
+SEARCH EXT words </td>
+ </tr>
+ <tr>
+ <td> <b>softcore.c</b> </td>
+ <td> Contains all of the "soft" words - those written in Forth and
+compiled by Ficl at startup time. Sources for these words are in the
+softwords directory. The files softwords/softcore.bat and
+softwords/softcore.pl generate softcore.c from the .fr sources. </td>
+ </tr>
+ <tr>
+ <td> <b>softwords/</b> </td>
+ <td> Directory contains sources and translation scripts for the
+words defined in softcore.c. Softcore.c depends on most of the files in
+this directory. See softcore.bat for the actual list of
+files that contribute to softcore.c. This is where you'll find source
+code for the object oriented extensions. PERL script softcore.pl
+converts the .fr files into softcore.c. </td>
+ </tr>
+ <tr>
+ <td> <b>stack.c</b> </td>
+ <td> Stack methods </td>
+ </tr>
+ <tr>
+ <td> <b>sysdep.c</b> </td>
+ <td> Implementation of system dependent functions declared in
+sysdep.h </td>
+ </tr>
+ <tr>
+ <td> <b>testmain.c</b> </td>
+ <td> The main() function for unix/linux/win32 console applications
+- use this as an example to integrate ficl into your system. Also
+contains some definitions for testing - also useful in
+unix/linux/win32 land. </td>
+ </tr>
+ <tr>
+ <td> <b>tools.c</b> </td>
+ <td> Contains C implementations of TOOLS and TOOLS EXT words, the
+debugger, and debugger support words. </td>
+ </tr>
+ <tr>
+ <td> <b>vm.c</b> </td>
+ <td> Virtual Machine methods </td>
+ </tr>
+ <tr>
+ <td> <b>win32.c &amp; unix.c</b> </td>
+ <td> Platform extensions words loaded in ficl.c by
+ficlCompilePlatform() - conditioned on FICL_WANT_PLATFORM </td>
+ </tr>
+ <tr>
+ <td> <b>words.c</b> </td>
+ <td> Exports ficlCompileCore(), the run-time dictionary builder,
+and contains most precompiled CORE and CORE-EXT words. </td>
+ </tr>
+ </tbody>
+</table>
+<hr>
+<h2> <a name="extras"></a>Ficl extras </h2>
+<h3> <a name="exnumber"></a>Number syntax </h3>
+You can precede a number with "0x", as in C, and it will be interpreted
+as a hex value regardless of the value of <code>BASE</code>. Likewise,
+numbers prefixed with "0d" will be interpreted as decimal values.
+Example:
+<pre>ok&gt; decimal 123 . cr<br>123<br>ok&gt; 0x123 . cr<br>291<br>ok&gt; 0x123 x. cr<br>123<br></pre>
+Note: ficl2.05 and later - this behavior is controlled by the <a
+ href="ficl_parse.html">prefix parser</a> defined in <code>prefix.c</code>.
+You can add other prefixes by defining handlers for them in ficl
+or C.
+<h3> <a name="exsearch"></a> The <code>SEARCH</code> wordset and Ficl
+extensions </h3>
+<p> Ficl implements many of the search order words in terms of two
+primitives called <code><a href="#tosearch">&gt;SEARCH</a></code> and <code><a
+ href="#searchfrom">SEARCH&gt;</a></code>. As their names
+suggest (assuming you're familiar with Forth), they push and pop the
+search order stack. </p>
+<p> The standard does not appear to specify any conditions under which
+the search order is reset to a sane state. Ficl resets the search order
+to its default state whenever <tt>ABORT</tt> happens. This includes
+stack underflows and overflows. <tt>QUIT</tt> does not affect the search
+order. The minimum search order (set by <tt>ONLY</tt>) is equivalent
+to </p>
+<pre>FORTH-WORDLIST 1 SET-ORDER<br></pre>
+<p> There is a default maximum of 16 wordlists in the search order. This
+can be changed by redefining FICL_DEFAULT_VOCS (declared in sysdep.h). </p>
+<p> <b>Note</b>: Ficl resets the search order whenever it does <tt>ABORT</tt>.
+If you don't like this behavior, just comment out the
+dictResetSearchOrder() lines in ficlExec(). </p>
+<dl>
+ <dt> <a name="tosearch"></a><code>&gt;search ( wid -- )</code> </dt>
+ <dd> Push <tt>wid</tt> onto the search order. Many of the other search
+order words are written in terms of the <tt>SEARCH&gt;</tt> and <tt>&gt;SEARCH</tt>
+primitives. This word can be defined in ANS Forth as follows </dd>
+ <dd> <tt>: &gt;search&nbsp;&nbsp; &gt;r get-order 1+ r&gt; swap
+set-order ;</tt> </dd>
+ <dt> <a name="searchfrom"></a><tt>search&gt;&nbsp;&nbsp; ( -- wid )</tt> </dt>
+ <dd> Pop <tt>wid</tt> off the search order (can be coded in ANS Forth
+as&nbsp;<tt>: search&gt;&nbsp; get-order nip 1- set-order ;</tt> ) </dd>
+ <dt> <a name="ficlsetcurrent"></a><tt>ficl-set-current&nbsp;&nbsp; (
+wid -- old-wid )</tt> </dt>
+ <dd> Set wid as compile wordlist, leaving the previous compile
+wordlist on the stack </dd>
+ <dt> <a name="ficlvocabulary"></a><tt>ficl-vocabulary&nbsp;&nbsp; (
+nBins "name" -- )</tt> </dt>
+ <dd> Creates a <tt>ficl-wordlist</tt> with the specified number of
+hash table bins, binds it to the name, and associates the semantics of <tt>vocabulary</tt>
+with it (replaces the top wid in the search order list with
+its own wid when executed) </dd>
+ <dt> <a name="ficlwordlist"></a><tt>ficl-wordlist&nbsp;&nbsp; ( nBins
+-- wid )</tt> </dt>
+ <dd> Creates a wordlist with the specified number of hash table bins,
+and leaves the address of the wordlist on the stack. A <tt>ficl-wordlist</tt>
+behaves exactly as a regular wordlist, but it may search
+faster depending on the number of bins chosen and the number of words it
+contains at search time. As implemented in ficl, a wordlist is single
+threaded by default. <tt> ficl-named-wordlist</tt> takes a name for the
+wordlist and creates a word that pushes the <tt>wid</tt>. This is by
+contrast to <tt>VOCABULARY</tt>, which also has a name, but replaces
+the top of the search order with its <tt>wid</tt>. </dd>
+ <dt> <a name="ficlforgetwid"></a><tt>forget-wid&nbsp;&nbsp; ( wid -- )</tt> </dt>
+ <dd> Iterates through the specified wordlist and unlinks all
+definitions whose xt addresses are greater than or equal to the value of <tt>HERE</tt>,
+the dictionary fill pointer.&nbsp; </dd>
+ <dt> <a name="ficlhide"></a><tt>hide&nbsp;&nbsp; ( -- current-wid-was
+)</tt> </dt>
+ <dd> Push the <tt>hidden</tt> wordlist onto the search order, and set
+it as the current compile wordlist (unsing <tt>ficl-set-current</tt>).
+Leaves the previous compile wordlist ID. I use this word to
+hide implementation factor words that have low reuse potential so that
+they don't clutter the default wordlist. To undo the effect of hide,
+execute&nbsp; <b><tt>previous set-current</tt></b> </dd>
+ <dt> <a name="ficlhidden"></a><tt>hidden&nbsp;&nbsp; ( -- wid )</tt> </dt>
+ <dd> Wordlist for storing implementation factors of ficl provided
+words. To see what's in there, try:&nbsp; <b><tt>hide words previous
+set-current</tt></b> </dd>
+ <dt> <a name="wid-get-name"></a><tt>wid-get-name&nbsp;&nbsp; ( wid --
+c-addr u )</tt> </dt>
+ <dd> Ficl wordlists (2.05 and later) have a name property that can be
+assigned. This is used by <tt>ORDER</tt> to list the names of wordlists
+in the search order.&nbsp; </dd>
+ <dt> <a name="wid-set-name"></a><tt>wid-set-name&nbsp;&nbsp; ( c-addr
+wid -- )</tt> </dt>
+ <dd> Ficl wordlists (2.05 and later) have a name property that can be
+assigned. This is used by <tt>ORDER</tt> to list the names of wordlists
+in the search order. The name is assumed to be a \0 terminated
+string (C style), which conveniently is how Ficl stores word
+names.&nbsp; See softwords/softcore.fr definition of <tt>brand-wordlist</tt>&nbsp;</dd>
+ <dt> <a name="wid-set-super"></a><tt>wid-set-super&nbsp;&nbsp; ( wid
+-- )</tt> </dt>
+ <dd> Ficl wordlists have a parent wordlist pointer that is not
+specified in standard Forth. Ficl initializes this pointer to NULL
+whenever it creates a wordlist, so it ordinarily has no effect.
+This word sets the parent pointer to the wordlist specified on the top
+of the stack. Ficl's implementation of <tt>SEARCH-WORDLIST</tt> will
+chain backward through the parent link of the wordlist when
+searching. This simplifies Ficl's object model in that the search order
+does not need to reflect an object's class hierarchy when searching for
+a method. It is possible to implement Ficl object syntax in
+strict ANS Forth, but method finders need to manipulate the search order
+explicitly. </dd>
+</dl>
+<h3> <a name="exuser"></a>User variables </h3>
+<dl>
+ <dt> <tt>user&nbsp;&nbsp; ( -- ) name</tt> </dt>
+ <dd> Create a user variable with the given name. User variables are
+virtual machine local. Each VM allocates a fixed amount of storage for
+them. You can change the maximum number of user variables
+allowed by defining FICL_USER_CELLS on your compiiler's command line.
+Default is 16 user cells. User variables behave like <tt>VARIABLE</tt>s
+in all other respects (you use @ and ! on them, for example).
+Example: </dd>
+ <dd>
+ <dl>
+ <dd> <tt>user current-class</tt> </dd>
+ <dd> <tt>0 current-class !</tt> </dd>
+ </dl>
+ </dd>
+</dl>
+<h3> <a name="exmisc"></a>Miscellaneous </h3>
+<dl>
+ <dt> <tt>-roll&nbsp;&nbsp; ( xu xu-1 ... x0 u -- x0 xu-1 ... x1
+)&nbsp;</tt> </dt>
+ <dd> Rotate u+1 items on top of the stack after removing u. Rotation
+is in the opposite sense to <tt>ROLL</tt> </dd>
+</dl>
+<dl>
+ <dt> <a name="minusrot"></a><tt>-rot&nbsp;&nbsp; ( a b c -- c a b )</tt> </dt>
+ <dd> Rotate the top three stack entries, moving the top of stack to
+third place. I like to think of this as <tt>1<sup>1</sup>/<sub>2</sub>swap</tt>
+because it's good for tucking a single cell value behind a
+cell-pair (like an object).&nbsp; </dd>
+</dl>
+<dl>
+ <dt> <tt>.env&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> List all environment variables of the system </dd>
+ <dt> <tt>.hash&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> List hash table performance statistics of the wordlist that's
+first in the search order </dd>
+ <dt> <tt>.ver&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Display ficl version ID </dd>
+ <dt> <tt>&gt;name&nbsp;&nbsp; ( xt -- c-addr u )</tt> </dt>
+ <dd> Convert a word's execution token into the address and length of
+its name </dd>
+ <dt> <tt>body&gt;&nbsp;&nbsp; ( a-addr -- xt )</tt> </dt>
+ <dd> Reverses the effect of <tt>CORE</tt> word <tt>&gt;body</tt>
+(converts a parameter field address to an execution token) </dd>
+ <dt> <tt>compile-only</tt> </dt>
+ <dd> Mark the most recently defined word as being executable only
+while in compile state. Many <tt>immediate</tt> words have this
+property. </dd>
+ <dt> <tt>empty&nbsp;&nbsp; ( -- )</tt>&nbsp; </dt>
+ <dd> Empty the parameter stack </dd>
+ <dt> <tt>endif</tt> </dt>
+ <dd> Synonym for <tt>THEN</tt> </dd>
+ <dt> <a name="last-word"></a><tt>last-word&nbsp;&nbsp; ( -- xt )</tt> </dt>
+ <dd> Pushes the xt address of the most recently defined word. This
+applies to colon definitions, constants, variables, and words that use <tt>create</tt>.
+You can print the name of the most recently defined word
+with&nbsp; </dd>
+ <dd> <b><tt>last-word &gt;name type</tt>&nbsp;</b> </dd>
+ <dt> <tt>parse-word&nbsp;&nbsp; ( &lt;spaces&gt;name -- c-addr u )</tt> </dt>
+ <dd> Skip leading spaces and parse name delimited by a space. c-addr
+is the address within the input buffer and u is the length of the
+selected string. If the parse area is empty, the resulting
+string has a zero length. (From the Standard) </dd>
+ <dt> <a name="qfetch"></a><tt>q@&nbsp;&nbsp; ( addr -- x )</tt> </dt>
+ <dd> Fetch a 32 bit quantity from the specified address </dd>
+ <dt> <a name="qbang"></a><tt>q!&nbsp;&nbsp; ( x addr -- )</tt> </dt>
+ <dd> Store a 32 bit quantity to the specified address&nbsp; </dd>
+ <dt> <tt>w@&nbsp;&nbsp; ( addr -- x )</tt> </dt>
+ <dd> Fetch a 16 bit quantity from the specified address </dd>
+ <dt> <tt>w!&nbsp;&nbsp; ( x addr -- )</tt> </dt>
+ <dd> Store a 16 bit quantity to the specified address (the low 16 bits
+of the given value) </dd>
+ <dt> <a name="xdot"></a><tt>x.&nbsp;&nbsp; ( x -- )</tt> </dt>
+ <dd> Pop and display the value in hex format, regardless of the
+current value of <tt>BASE</tt> </dd>
+</dl>
+<h3> <a name="exficlwin"></a>Extra words defined in testmain.c (Win32
+and POSIX versions) </h3>
+<dl>
+ <dt> <tt>break&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Does nothing - just a handy place to set a debugger breakpoint </dd>
+ <dt> <tt>cd&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (
+"directory-name&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Executes the Win32 chdir() function, changing the program's
+logged directory. </dd>
+ <dt> <a name="clock"></a><tt>clock&nbsp;&nbsp; ( -- now )</tt> </dt>
+ <dd> Wrapper for the ANSI C clock() function. Returns the number of
+clock ticks elapsed since process start. </dd>
+ <dt> <a name="clockspersec"></a><tt>clocks/sec&nbsp;&nbsp; ( --
+clocks_per_sec )</tt> </dt>
+ <dd> Pushes the number of ticks in a second as returned by <tt>clock</tt> </dd>
+ <dt> <a name="ficlload"></a><tt>load&nbsp;&nbsp;&nbsp; (
+"filename&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Opens the Forth source file specified and loads it one line at a
+time, like <tt>INCLUDED (FILE)</tt> </dd>
+ <dt> <tt>pwd&nbsp;&nbsp;&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Prints the current working directory as set by <tt>cd</tt> </dd>
+ <dt> <tt>system&nbsp; ( "command&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Issues a command to a shell; implemented with the Win32 system()
+call. </dd>
+ <dt> <tt>spewhash&nbsp;&nbsp; ( "filename&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Dumps all threads of the current compilation wordlist to the
+specified text file. This was useful when I thought there might be some
+point in attempting to optimize the hash function. I no longer
+harbor those illusions. </dd>
+</dl>
+<h3> Words defined in FiclWin only </h3>
+<dl>
+ <dt> <tt>!oreg&nbsp;&nbsp; ( c -- )</tt> </dt>
+ <dd> Set the value of the simulated LED register as specified (0..255)
+ </dd>
+ <dt> <tt>@ireg&nbsp;&nbsp; ( -- c )</tt> </dt>
+ <dd> Gets the value of the simulated switch block (0..255) </dd>
+ <dt> <tt>!dac&nbsp;&nbsp;&nbsp; ( c -- )</tt> </dt>
+ <dd> Sets the value of the bargraph control as specified. Valid values
+range from 0..255 </dd>
+ <dt> <tt>@adc&nbsp;&nbsp;&nbsp; ( -- c )</tt> </dt>
+ <dd> Fetches the current position of the slider control. Range is
+0..255 </dd>
+ <dt> <tt>status"&nbsp;&nbsp; ( "ccc&lt;quote&gt;" -- )</tt> </dt>
+ <dd> Set the mainframe window's status line to the text specified, up
+to the first trailing quote character. </dd>
+ <dt> <a name="ficlms"></a><tt><a
+ href="http://www.taygeta.com/forth/dpans10.htm#10.6.2.1905">ms</a>&nbsp;&nbsp;
+( u -- )</tt> </dt>
+ <dd> Causes the running virtual machine to sleep() for the number of
+milliseconds specified by the top-of-stack value. </dd>
+</dl>
+<hr>
+<h2> <a name="ansinfo"></a>ANS Required Information </h2>
+<b>ANS Forth System</b><br>
+<b>Providing names from the Core Extensions word set&nbsp;</b><br>
+<b>Providing the Exception word set</b><br>
+<b>Providing names from the Exception Extensions word set</b><br>
+<b>Providing the Locals word set&nbsp;</b><br>
+<b>Providing the Locals Extensions word set&nbsp;</b><br>
+<b>Providing the Memory Allocation word set</b><br>
+<b>Providing the Programming-Tools word set</b><br>
+<b>Providing names from the Programming-Tools Extensions word set</b><br>
+<b>Providing the Search-Order word set</b><br>
+<b>Providing the Search-Order Extensions word set</b>
+<h3> Implementation-defined Options </h3>
+The implementation-defined items in the following list represent
+characteristics and choices left to the discretion of the implementor,
+provided that the requirements of the Standard are met. A system
+shall document the values for, or behaviors of, each item.&nbsp;
+<ul>
+ <li> <b>aligned address requirements (3.1.3.3 Addresses);</b>&nbsp; </li>
+ <li> <br>
+ <font color="#000000">System dependent. You can change the default
+address alignment by defining FICL_ALIGN on your compiler's command
+line. The default value is set to 2 in sysdep.h. This causes
+dictionary entries and <tt>ALIGN</tt> and <tt>ALIGNED</tt> to align on 4
+byte boundaries. To align on <b>2<sup>n</sup></b> byte boundaries, set
+FICL_ALIGN to <b>n</b>.&nbsp;</font> </li>
+ <li> <b>behavior of 6.1.1320 EMIT for non-graphic characters</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Depends on target system, C runtime library,
+and your implementation of ficlTextOut().</font> </li>
+ <li> <b>character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">None implemented in the versions supplied in
+words.c. Because ficlExec() is supplied a text buffer externally, it's
+up to your system to define how that buffer will be obtained.</font> </li>
+ <li> <b>character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750
+KEY)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Depends on target system and implementation
+of ficlTextOut()</font> </li>
+ <li> <b>character-aligned address requirements (3.1.3.3 Addresses)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl characters are one byte each. There are
+no alignment requirements.</font> </li>
+ <li> <b>character-set-extensions matching characteristics (3.4.2
+Finding definition n<font color="#000000">ames)</font></b><font
+ color="#000000">;&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">No special processing is performed on
+characters beyond case-folding. Therefore, extended characters will not
+match their unaccented counterparts.</font> </li>
+ <li> <b>conditions under which control characters match a space
+delimiter (3.4.1.1 Delimiters)</b>;<font color="#ff6666">&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">Ficl uses the Standard C function isspace()
+to distinguish space characters. The rest is up to your library vendor.</font> </li>
+ <li> <b>format of the control-flow stack (3.2.3.2 Control-flow stack)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Uses the data stack</font> </li>
+ <li> <b>conversion of digits larger than thirty-five (3.2.1.2 Digit
+conversion)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">The maximum supported value of <tt>BASE</tt>
+is 36. Ficl will assertion fail in function ltoa of vm.c if the base is
+found to be larger than 36 or smaller than 2. There will be no
+effect if NDEBUG is defined</font>, however, other than possibly
+unexpected behavior.&nbsp; </li>
+ <li> <b>display after input terminates in 6.1.0695 ACCEPT and
+6.2.1390 EXPECT</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Target system dependent</font> </li>
+ <li> <b>exception abort sequence (as in 6.1.0680 ABORT")</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Does <tt>ABORT</tt></font> </li>
+ <li> <b>input line terminator (3.2.4.1 User input device)</b>;<font
+ color="#ff0000">&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">Target system dependent (implementation of
+outer loop that calls ficlExec)</font> </li>
+ <li> <b>maximum size of a counted string, in characters (3.1.3.4
+Counted strings, 6.1.2450 WORD)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">255</font> </li>
+ <li> <b>maximum size of a parsed string (3.4.1 Parsing)</b>;&nbsp; </li>
+ <li> <br>
+Limited by available memory and the maximum unsigned value that can fit
+in a CELL (2<sup>32</sup>-1).&nbsp; </li>
+ <li> <b>maximum size of a definition name, in characters (3.3.1.2
+Definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl stores the first 31 characters of a
+definition name.</font> </li>
+ <li> <b>maximum string length for 6.1.1345 ENVIRONMENT?, in characters</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Same as maximum definition name length</font> </li>
+ <li> <b>method of selecting 3.2.4.1 User input device</b>;&nbsp; </li>
+ <li> <br>
+None supported. This is up to the target system&nbsp; </li>
+ <li> <b>method of selecting 3.2.4.2 User output device</b>;&nbsp; </li>
+ <li> <br>
+None supported. This is up to the target system&nbsp; </li>
+ <li> <b>methods of dictionary compilation (3.3 The Forth dictionary)</b>;&nbsp;</li>
+ <li> <b>number of bits in one address unit (3.1.3.3 Addresses)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Target system dependent. Ficl generally
+supports processors that can address 8 bit quantities, but there is no
+dependency that I'm aware of.</font> </li>
+ <li> <b>number representation and arithmetic (3.2.1.1 Internal number
+representation)</b>;&nbsp; </li>
+ <li> <br>
+System dependent. Ficl represents a CELL internally as a union that can
+hold INT32 (a signed 32 bit scalar value), UNS32 (32 bits unsigned), and
+an untyped pointer. No specific byte ordering is
+assumed.&nbsp; </li>
+ <li> <b>ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types,
+3.1.4 Cell-pair types)</b>;&nbsp; </li>
+ <li> <br>
+Assuming a 32 bit implementation, range for signed single-cell values
+is -2<sup>31</sup>..2<sup>31</sup>-1. Range for unsigned single cell
+values is 0..2<sup>32</sup>-1. Range for signed double-cell
+values is -2<sup>63</sup>..2<sup>63</sup>-1. Range for unsigned single
+cell values is 0..2<sup>64</sup>-1.&nbsp; </li>
+ <li> <b>read-only data-space regions (3.3.3 Data space)</b>; </li>
+ <li> <br>
+None&nbsp; </li>
+ <li> <b>size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient
+regions)</b>;&nbsp; </li>
+ <li> <br>
+Default is 255. Depends on the setting of nPAD in ficl.h.&nbsp; </li>
+ <li> <b>size of one cell in address units (3.1.3 Single-cell types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">System dependent, generally four.</font> </li>
+ <li> <b>size of one character in address units (3.1.2 Character types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">System dependent, generally one.</font> </li>
+ <li> <b>size of the keyboard terminal input buffer (3.3.3.5 Input
+buffers)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">This buffer is supplied by the host program.
+Ficl imposes no practical limit.</font> </li>
+ <li> <b>size of the pictured numeric output string buffer (3.3.3.6
+Other transient regions)</b>;&nbsp; </li>
+ <li> <br>
+Default is 255 characters. Depends on the setting of nPAD in
+ficl.h.&nbsp; </li>
+ <li> <b>size of the scratch area whose address is returned by
+6.2.2000 PAD (3.3.3.6 Other transient regions)</b>;&nbsp; </li>
+ <li> <br>
+Not presently supported&nbsp; </li>
+ <li> <b>system case-sensitivity characteristics (3.4.2 Finding
+definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl is not case sensitive</font> </li>
+ <li> <b>system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">"ok&gt;"</font> </li>
+ <li> <b>type of division rounding (3.2.2.1 Integer division, 6.1.0100
+*/, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Symmetric</font> </li>
+ <li> <b>values of 6.1.2250 STATE when true</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">One (no others)</font> </li>
+ <li> <b>values returned after arithmetic overflow (3.2.2.2 Other
+integer operations)</b>;&nbsp; </li>
+ <li> <br>
+System dependent. Ficl makes no special checks for overflow.&nbsp; </li>
+ <li> <b>whether the current definition can be found after 6.1.1250
+DOES&gt; (6.1.0450 :)</b>.&nbsp; </li>
+ <li> <br>
+ <font color="#000000">No. Definitions are unsmudged after ; only,
+and only then if no control structure matching problems have been
+detected.</font> </li>
+</ul>
+<h3> Ambiguous Conditions </h3>
+A system shall document the system action taken upon each of the
+general or specific ambiguous conditions identified in this Standard.
+See 3.4.4 Possible actions on an ambiguous condition.&nbsp;
+<p> The following general ambiguous conditions could occur because of a
+combination of factors:&nbsp; </p>
+<ul>
+ <li> <b>a name is neither a valid definition name nor a valid number
+during text interpretation (3.4 The Forth text interpreter)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl does <tt>ABORT</tt> and prints the name
+followed by " not found".</font> </li>
+ <li> <b>a definition name exceeded the maximum length allowed
+(3.3.1.2 Definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl stores the first 31 characters of the
+definition name, and uses all characters of the name in computing its
+hash code. The actual length of the name, up to 255
+characters, is stored in the definition's length field.</font> </li>
+ <li> <b>addressing a region not listed in 3.3.3 Data Space</b>;&nbsp;
+ </li>
+ <li> <br>
+ <font color="#000000">No problem: all addresses in ficl are
+absolute. You can reach any 32 bit address in Ficl's address space.</font> </li>
+ <li> <b>argument type incompatible with specified input parameter,
+e.g., passing a flag to a word expecting an n (3.1 Data types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl makes no check for argument type
+compatibility. Effects of a mismatch vary widely depending on the
+specific problem and operands.</font> </li>
+ <li> <b>attempting to obtain the execution token, (e.g., with
+6.1.0070 ', 6.1.1550 FIND, etc.) of a definition with undefined
+interpretation semantics</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl returns a valid token, but the result of
+executing that token while interpreting may be undesirable.</font> </li>
+ <li> <b>dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /,
+6.1.0240 /MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370
+UM/MOD, 8.6.1.1820 M*/)</b>; </li>
+ <li> <br>
+ <font color="#000000">Results are target procesor dependent.
+Generally, Ficl makes no check for divide-by-zero. The target processor
+will probably throw an exception.</font> </li>
+ <li> <b>insufficient data-stack space or return-stack space (stack
+overflow)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">With FICL_ROBUST (sysdep.h) set &gt;= 2, most
+parameter stack operations are checked for underflow and overflow. Ficl
+does not check the return stack.</font> </li>
+ <li> <b>insufficient space for loop-control parameters</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">No check - Evil results.</font> </li>
+ <li> <b>insufficient space in the dictionary</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl generates an error message if the
+dictionary is too full to create a definition header. It checks <tt>ALLOT</tt>
+as well, but it is possible to make an unchecked allocation
+request that overflows the dictionary.</font> </li>
+ <li> <b>interpreting a word with undefined interpretation semantics</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl protects all ANS Forth words with
+undefined interpretation semantics from being executed while in
+interpret state. It is possible to defeat this protection using
+' (tick) and <tt>EXECUTE</tt>, though.</font> </li>
+ <li> <b>modifying the contents of the input buffer or a string
+literal (3.3.3.4 Text-literal regions, 3.3.3.5 Input buffers)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Varies depending on the nature of the buffer.
+The input buffer is supplied by ficl's host function, and may reside in
+read-only memory. If so, writing the input buffer can ganerate
+an exception. String literals are stored in the dictionary, and are
+writable.</font> </li>
+ <li> <b>overflow of a pictured numeric output string</b>; </li>
+ <li> <br>
+In the unlikely event you are able to construct a pictured numeric
+string of more than 255 characters, the system will be corrupted
+unpredictably. The buffer area that holds pictured numeric
+output is at the end of the virtual machine. Whatever is mapped after
+the offending VM in memory will be trashed, along with the heap
+structures that contain it.&nbsp; </li>
+ <li> <b>parsed string overflow</b>; </li>
+ <li> <br>
+Ficl does not copy parsed strings unless asked to. Ordinarily, a string
+parsed from the input buffer during normal interpretation is left
+in-place, so there is no possibility of overflow. If you ask
+to parse a string into the dictionary, as in <tt>SLITERAL</tt>, you
+need to have enough room for the string, otherwise bad things may
+happen. This is not usually a problem.&nbsp; </li>
+ <li> <b>producing a result out of range, e.g., multiplication (using
+*) results in a value too big to be represented by a single-cell integer
+(6.1.0090 *, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570
+&gt;NUMBER, 6.1.1561 FM/MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 6.2.0970
+CONVERT, 8.6.1.1820 M*/)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Value will be truncated</font> </li>
+ <li> <b>reading from an empty data stack or return stack (stack
+underflow)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Most stack underflows are detected and
+prevented if FICL_ROBUST (sysdep.h) is set to 2 or greater. Otherwise,
+the stack pointer and size are likely to be trashed.</font> </li>
+ <li> <b>unexpected end of input buffer, resulting in an attempt to
+use a zero-length string as a name</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl returns for a new input buffer until a
+non-empty one is supplied.</font> </li>
+</ul>
+The following specific ambiguous conditions are noted in the glossary
+entries of the relevant words:&nbsp;
+<ul>
+ <li> <b>&gt;IN greater than size of input buffer (3.4.1 Parsing)</b> </li>
+ <li> <br>
+Bad Things occur - unpredictable bacause the input buffer is supplied
+by the host program's outer loop.&nbsp; </li>
+ <li> <b>6.1.2120 RECURSE appears after 6.1.1250 DOES&gt;</b> </li>
+ <li> <br>
+It finds the address of the definition before <tt>DOES&gt;</tt> </li>
+ <li> <b>argument input source different than current input source for
+6.2.2148 RESTORE-INPUT</b> </li>
+ <li> <br>
+Not implemented&nbsp; </li>
+ <li> <b>data space containing definitions is de-allocated (3.3.3.2
+Contiguous regions)</b> </li>
+ <li> <br>
+This is OK until the cells are overwritten with something else. The
+dictionary maintains a hash table, and the table must be updated in
+order to de-allocate words without corruption.&nbsp; </li>
+ <li> <b>data space read/write with incorrect alignment (3.3.3.1
+Address alignment)</b> </li>
+ <li> <br>
+Target processor dependent. Consequences include: none (Intel), address
+error exception (68K).&nbsp; </li>
+ <li> <b>data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860
+C,)</b> </li>
+ <li> <br>
+See above on data space read/write alignment&nbsp; </li>
+ <li> <b>less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)</b> </li>
+ <li> <br>
+Ficl detects a stack underflow and reports it, executing <tt>ABORT,</tt>
+as long as FICL_ROBUST is two or larger.&nbsp; </li>
+ <li> <b>loop-control parameters not available ( 6.1.0140 +LOOP,
+6.1.1680 I, 6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)</b> </li>
+ <li> <br>
+Loop initiation words are responsible for checking the stack and
+guaranteeing that the control parameters are pushed. Any underflows will
+be detected early if FICL_ROBUST is set to two or greater.
+Note however that Ficl only checks for return stack underflows at the
+end of each line of text.&nbsp; </li>
+ <li> <b>most recent definition does not have a name (6.1.1710
+IMMEDIATE)</b> </li>
+ <li> <br>
+No problem.&nbsp; </li>
+ <li> <b>name not defined by 6.2.2405 VALUE used by 6.2.2295 TO</b> </li>
+ <li> <br>
+Ficl's version of <tt>TO</tt> works correctly with <tt>VALUE</tt>s, <tt>CONSTANT</tt>s
+and <tt>VARIABLE</tt>s.&nbsp; </li>
+ <li> <b>name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['],
+6.2.2530 [COMPILE])</b> </li>
+ <li> <br>
+Ficl prints an error message and does <tt>ABORT</tt> </li>
+ <li> <b>parameters are not of the same type (6.1.1240 DO, 6.2.0620
+?DO, 6.2.2440 WITHIN)</b> </li>
+ <li> <br>
+No check. Results vary depending on the specific problem.&nbsp; </li>
+ <li> <b>6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO</b> </li>
+ <li> <br>
+The word is postponed correctly.&nbsp; </li>
+ <li> <b>string longer than a counted string returned by 6.1.2450 WORD</b> </li>
+ <li> <br>
+Ficl stores the first FICL_STRING_MAX-1 chars in the destination
+buffer. (The extra character is the trailing space required by the
+standard. Yuck.)&nbsp; </li>
+ <li> <b>u greater than or equal to the number of bits in a cell
+(6.1.1805 LSHIFT, 6.1.2162 RSHIFT)</b> </li>
+ <li> <br>
+Depends on target process or and C runtime library implementations of
+the &lt;&lt; and &gt;&gt; operators on unsigned values. For I386, the
+processor appears to shift modulo the number of bits in a
+cell.&nbsp; </li>
+ <li> <b>word not defined via 6.1.1000 CREATE (6.1.0550 &gt;BODY,
+6.1.1250 DOES&gt;)</b> </li>
+ <li> <br>
+ <b>words improperly used outside 6.1.0490 &lt;# and 6.1.0040 #&gt;
+(6.1.0030 #, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)</b><br>
+Don't. <tt>CREATE</tt> reserves a field in words it builds for <tt>DOES&gt;</tt>to
+fill in. If you use <tt>DOES&gt;</tt> on a word not made by <tt>CREATE</tt>,
+it will overwrite the first cell of its parameter area.
+That's probably not what you want. Likewise, pictured numeric words
+assume that there is a string under construction in the VM's scratch
+buffer. If that's not the case, results may be unpleasant. </li>
+</ul>
+<h3> Locals Implementation-defined options </h3>
+<ul>
+ <li> <b>maximum number of locals in a definition (13.3.3 Processing
+locals, 13.6.2.1795 LOCALS|)</b> </li>
+ <li> <br>
+Default is 16. Change by redefining FICL_MAX_LOCALS, defined in
+sysdep.h </li>
+</ul>
+<h3> Locals Ambiguous conditions </h3>
+<ul>
+ <li> <b>executing a named local while in interpretation state
+(13.6.1.0086 (LOCAL))</b> </li>
+ <li> <br>
+Locals can be found in interpretation state while in the context of a
+definition under construction. Under these circumstances, locals behave
+correctly. Locals are not visible at all outside the scope of
+a definition.&nbsp; </li>
+ <li> <b>name not defined by VALUE or LOCAL (13.6.1.2295 TO)</b> </li>
+ <li> <br>
+See the CORE ambiguous conditions, above (no change) </li>
+</ul>
+<h3> Programming Tools Implementation-defined options </h3>
+<ul>
+ <li> <b>source and format of display by 15.6.1.2194 SEE</b> </li>
+ <li> <br>
+SEE de-compiles definitions from the dictionary. Because Ficl words are
+threaded by their header addresses, it is very straightforward to print
+the name and other characteristics of words in a definition.
+Primitives are so noted. Colon definitions are decompiled, but branch
+target labels are not reconstructed. Literals and string literals are so
+noted, and their contents displayed. </li>
+</ul>
+<h3> Search Order Implementation-defined options </h3>
+<ul>
+ <li> <b>maximum number of word lists in the search order (16.3.3
+Finding definition names, 16.6.1.2197 SET-ORDER)</b>&nbsp; </li>
+ <li> <br>
+Defaults to 16. Can be changed by redefining FICL_DEFAULT_VOCS,
+declared in sysdep.h&nbsp; </li>
+ <li> <b>minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)</b>&nbsp;</li>
+ <li> <br>
+Equivalent to <tt>FORTH-WORDLIST 1 SET-ORDER</tt> </li>
+</ul>
+<h3> Search Order Ambiguous conditions </h3>
+<ul>
+ <li> <b>changing the compilation word list (16.3.3 Finding definition
+names)</b> </li>
+ <li> <br>
+Ficl stores a link to the current definition independently of the
+compile wordlist while it is being defined, and links it into the
+compile wordlist only after the definition completes
+successfully. Changing the compile wordlist mid-definition will cause
+the definition to link into the <i>new</i> compile wordlist.&nbsp; </li>
+ <li> <b>search order empty (16.6.2.2037 PREVIOUS)</b> </li>
+ <li> <br>
+Ficl prints an error message if the search order underflows, and resets
+the order to its default state.&nbsp; </li>
+ <li> <b>too many word lists in search order (16.6.2.0715 ALSO)</b> </li>
+ <li> <br>
+Ficl prints an error message if the search order overflows, and resets
+the order to its default state. </li>
+</ul>
+</div>
+</body>
+</html>
diff --git a/doc/ficl1.ico b/doc/ficl1.ico
deleted file mode 100644
index 403bd6f56cb9..000000000000
--- a/doc/ficl1.ico
+++ /dev/null
Binary files differ
diff --git a/doc/ficl_debug.html b/doc/ficl_debug.html
deleted file mode 100644
index 647b7b27a8d0..000000000000
--- a/doc/ficl_debug.html
+++ /dev/null
@@ -1,111 +0,0 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta name="Author" content="john sadler">
- <title>Ficl Debugger</title>
-</head>
-<body>
-<link REL="SHORTCUT ICON" href="ficl.ico">
-<h1><b>Ficl Debugger</b></h1>
-
-<script language="javascript" src="ficlheader.js"></script>
-
-<table COLS=1 WIDTH="650" >
-<tr>
-<td>
-<p>Ficl release 2.05 includes a simple step debugger for colon definitions
-and does> words. If you use it and can suggest improvements (or better
-yet if you write some), please let me know.</p>
-<h2>Using the debugger</h2>
-To debug a word, set up the stack with any parameters the word requires,
-then type:
-
-<b><pre>debug &lt;your word here></pre></b>
-
-<p>If the word is unnamed, or all you have is an xt, you can instead use:</p>
-<b><code>debug-xt ( xt -- )</code></b>
-<p>The debugger invokes <tt>see</tt> on the word, printing a crude source
-listing, then stops at the first instruction of the definition. There are
-four (case insensitive) commands you can use from here onwards:</p>
-
-<dl>
-<dt>I (step in)</dt>
-<dd>If the next instruction is a colon defintion or does> word, steps into
-that word's code. If the word is a primitive, simply executes the word.</dd>
-
-<dt>O (step over)</dt>
-<dd>Executes the next instruction in its entirety</dd>
-
-<dt>G (go)</dt>
-<dd>Run the word to completion and exit the debugger</dd>
-
-<dt>L (list)</dt>
-<dd>Lists the source code of the word presently being stepped</dd>
-
-<dt>Q (quit)</dt>
-<dd>Abort the word and exit the debugger, clearing the stack</dd>
-
-<dt>X (eXecute)</dt>
-<dd>Interpret the remainder of the line as ficl words for their side effects.
-Any errors will abort the debug session and reset the VM. Usage example:
-<pre>
-x drop 3 \ fix argument on stack
-</pre>
-</dd>
-
-<dt>Anything else</dt>
-<dd>Prints a list of available debugger commands</dd>
-</dl>
-
-<h2>The on-step event</h2>
-<p>If there is a defined word named <code>on-step</code> when the debugger starts, that
-word will be executed before every step. As a guideline, this word should
-have no side effects. Its intended use is to display the stacks and any other
-VM state you're interested in, but you
-may have some better ideas. If so, please let me know. The default on-step is:<p>
-<b><code>: on-step ." S: " .s cr ;</code></b>
-
-<h3>Other useful words for debugging and on-step</h3>
-<dl>
-<dt><code>r.s ( -- )</code></dt>
-<dd>Prints a represention of the state of the return stack non-destructively. You have to have
-a good understanding of the return stack side-effects of control words to make sense of it,
-but it does give an accurate representation of what's there. Example: <code>DO .. LOOP</code>s stack
-three parameters on the return stack: the loop count and limit, and the <code>LEAVE</code> target
-address.</dd>
-<dt><code>.s ( -- )</code></dt>
-<dd>Prints the parameter stack non-destructively</dd>
-<dt><code>f.s ( -- )</code></dt>
-<dd>Prints the float stack non-destructively (only available if FICL_WANT_FLOAT is enabled)</dd>
-</dl>
-<h2>Debugger internals</h2>
-<p>
-The debugger words are mostly located in source file <tt>tools.c</tt>. There are
-supporting words (<code>debug</code> and <code>on-step</code>) in softcore.fr as well.
-There are two main words that make the debugger go: debug-xt and step-break.
-Debug-xt takes the xt of a word to debug (as returned by <tt>'</tt>, for example)
-checks to see if it is debuggable (not a primitive), sets a breakpoint at its
-first instruction, and runs <code>see</code> on it. To set a breakpoint,
-<code>debug-xt</code>
-replaces the instruction at the breakpoint with the xt of <code>step-break</code>, and
-stores the original instruction and its address in a static breakpoint
-record. To clear the breakpoint, <code>step-break</code> simply replaces the original
-instruction and adjusts the target virtual machine's instruction pointer
-to run it.
-</p>
-<p><code>Step-break</code> is responsible for processing debugger commands and setting
-breakpoints at subsequent instructions.</p>
-<h3>To Do</h3>
-<bl>
-<li>The debugger needs to exit automatically when it encounters the end of the word
-it was asked to debug. Perhaps this could be a special kind of breakpoint?
-</li>
-<li>Add user-set breakpoints</li>
-<li>Add "step out" command</li>
-</bl>
-</td>
-</tr>
-</table>
-
-</body>
-</html>
diff --git a/doc/ficl_guts.htm b/doc/ficl_guts.htm
deleted file mode 100644
index ba982c454a3f..000000000000
--- a/doc/ficl_guts.htm
+++ /dev/null
@@ -1,69 +0,0 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Author" content="john sadler">
- <meta name="Description" content="the coolest embedded scripting language ever">
- <title>Ficl - Internals</title>
-</head>
-<body>
-<link REL="SHORTCUT ICON" href="ficl.ico">
-<h1><b>Ficl Internal Structures</b></h1>
-
-<script language="javascript" src="ficlheader.js"></script>
-
-<h2>Contents</h2>
-
-<h2>Major Data Structures</h2>
-<p>
-A running memory image of Ficl consists of one or more FICL_SYSTEMs,
-each of which owns exactly one dictionary (FICL_DICT),
-and one or more virtual machines (FICL_VM). Each VM owns two stacks
-(FICL_STACK) - one for parameters (the parameter stack)
-and one for return addresses (the return stack).
-Ficl is a permissive, untyped language by nature,
-so its fundamental unit of storage is a CELL: a chunk of memory
-large enough to hold an address or a scalar type.
-</p>
-<h3>FICL_SYSTEM</h3>
-The system structure associates one or more virtual machines with a dictionary. All FICL_SYSTEMS
-include a link pointer that is used to keep track of every allocated system so that memory
-can be freed by ficlTermSystem. Each system contains a list of virtual machines associated with
-it. Each system has at least one virtual machine. In a typical implementation, there is one virtual
-machine per native OS thread, and there may be several VMs sharing a single FICL_SYSTEM, or one
-FICL_SYSTEM per VM if the implementation needs to support multiple user sessions in a robust way.
-
-A FICL_SYSTEM also includes a special dictionary for local variable support (if enabled
-by FICL_WANT_LOCALS) and another for environment variable support. Environment variables
-describe the configuration of the system in conformance with American National Standard Forth
-(ANS Forth).
-<h3>FICL_DICT</h3>
-A dictionary manages a fixed-size block of contiguous memory. It serves two roles: to keep track
-of allocated memory, and to collect symbol tables called wordlists. Each dictionary contains at
-least one wordlist. The dictionary organized memory (perhaps this is too kind) as an array of
-CELLs that grows from low memory to high memory within fixed limits determined by the
-FICL_DEFAULT_DICT parameter in sysdep.h.
-
-A wordlist is the controlling structure of a Ficl symbol table. Each wordlist is a hash table
-containing pointers to FICL_WORDs. Each FICL_WORD associates a pointer to code with one or more
-CELLs of the dictionay. Each word usually has a name as well, but this is not required. It is
-possible to create anonymous words using :NONAME.
-
-Each word's code pointer determines that word's runtime behavior, and by implication the purpose
-of its payload data. Some words interpret their payload as a list of Ficl words, and execute them.
-This is how new behaviors of the language are defined. Other words view their payload field as
-a location in which one or more CELLs can be stored (VARIABLEs, for example). At runtime, such
-words push the address of their payload area onto the parameter stack.
-<h3>FICL_VM</h3>
-The virtual machine collects state related to execution of Ficl words. Each VM includes
-registers used by the inner interpreter, some state variables (AKA user variables) such as
-the current numeric base, and a jmpbuf.
-A VM has a pointer to the FICL_SYSTEM of which it is a part. It also has a pointer to an incoming
-text string that it is interpreting. There are VM methods that excute a word given its address
-(xt), and ones that interpret a text string.
-<h3>FICL_STACK</h3>
-Each VM owns a parameter stack, a return stack, and if float support is enabled, a float parameter
-stack. Parameters, return addresses, and floats are all CELL sized, and values may be
-moved back and forth among stacks using various Ficl words for that purpose.
-</BODY>
-</HTML>
diff --git a/doc/ficl_loc.html b/doc/ficl_loc.html
deleted file mode 100644
index 6e00e74b9ee3..000000000000
--- a/doc/ficl_loc.html
+++ /dev/null
@@ -1,161 +0,0 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Author" content="john sadler">
- <meta name="Description" content="the coolest embedded scripting language ever">
- <meta name="GENERATOR" content="Mozilla/4.73 [en] (Win98; U) [Netscape]">
- <title>ficl Local Variables</title>
-</head>
-<body>
-
-<h1>
-<b>Local Variables in Ficl</b></h1>
-
-
-<script language="javascript" src="ficlheader.js"></script>
-
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h2>
-<a NAME="locals"></a>Local Variables</h2>
-Named locally scoped variables came late to Forth. Purists feel that experienced
-Forth programmers can (and should) write supportable code using only anonymous
-stack variables and good factoring, but they complain that novices use
-global variables too much. Local variables cost little in terms of code
-size and execution speed, and are very convenient for OO programming, where
-stack effects are more complex. I use them a lot (maybe I'm a weenie).&nbsp;
-<br><a href="http://www.taygeta.com/forth/dpans13.htm">Please refer to
-the Standard</a> for more information on local variables.
-<h2>
-<a NAME="jhlocal"></a>Johns-Hopkins local variables</h2>
-ANS Forth does not specify a complete and satisfying local variable facility.
-Instead it defines a foundation upon which to build one. Ficl comes with
-an adaptation of the Johns-Hopkins local variable syntax developed by John
-Hayes et al. This is my preferred form, and I've extended it to make <a href="ficl_oop.html">OOP</a>
-a bit simpler. Local variables can only be declared inside a definition,
-and are only visible in that definition. Here's the syntax of a JH local
-variable declaration:
-<blockquote><tt><b>{ </b>&lt;initialized-locals><b> | </b>&lt;cleared-locals><b>
--- </b>&lt;ignored><b> }</b></tt></blockquote>
-The declaration is designed to look like a stack comment, but it uses curly
-braces instead of parens. The &lt;initialized-locals> names get their initial
-values from the stack when the word executes. The &lt;cleared-locals> names
-are (you guessed it) set to zero when the word executes, and any characters
-between -- and } are treated as a comment. The | and -- sections are optional,
-but they must appear in the order shown if they appear at all.&nbsp;
-<br><b>Double cell locals </b>(AKA 2locals): ordinarily, each local represents
-one cell. Local variable names prefixed with the characters "2:" in the declaration
-are double-cell locals. The prefix is not part of the local variable's name, only
-part of the declaration.
-They behave the same as single cell locals in all
-other respects. I use 2locals quite a bit in Ficl's OO classes, because
-objects in Ficl require two cells on the stack. You can modify the
-value of a double cell local with <tt><a href="http://www.taygeta.com/forth/dpans13.htm#13.6.1.2295">TO</a></tt>
-the same as you would a single cell local.
-<br>Following are some examples to illustrate usage (they are not intended
-to be good code otherwise). Try these out in FiclWin to get a feeling for
-how they work. Also see <code>softwords/string.fr</code> for an example of use of locals
-in OO code.
-<blockquote><b><tt>: local-demo&nbsp; { a b | c -- }</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; ." a = " a . cr</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; ." b = " b . cr</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; ." c = " c . cr ;</tt></b>
-<br><b><tt>1 2 local-demo&nbsp; ( you should see 1 2 0 )</tt></b>
-<p><b><tt>: my2dup&nbsp; { 2:x }&nbsp;&nbsp; x x ;&nbsp; ( uses a 2local
-)</tt></b>
-<br><b><tt>1 2 my2dup .s&nbsp;</tt></b>
-<br><b><tt>.( you should see 1 2 1 2 on the stack ) cr empty</tt></b>
-<p><b><tt>: my2swap&nbsp;&nbsp; { 2:x 2:y -- y x }&nbsp;&nbsp; y x ;&nbsp;
-( note use of 2locals )</tt></b>
-<br><b><tt>1 2 3 4 my2swap .s</tt></b>
-<br><b><tt>.( you should see 3 4 1 2 on the stack ) cr empty</tt></b>
-<p><b><tt>: totally-lame-swap&nbsp; { x y | temp -- y x }</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; y to temp</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; x to y</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; temp to x</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; x y ;</tt></b></blockquote>
-The last definition introduces the use of <tt>TO</tt> applied to local
-variables. <tt>TO</tt> knows whether it's operating on a <tt>LOCAL</tt>,
-a <tt>2LOCAL</tt>, or a <tt>VALUE</tt>, and does the right thing accordingly.&nbsp;
-<br>&nbsp;
-<h2>Other local variable syntaxes (deprecated)</h2>
-There are other syntaxes in use for local variables. You get the same compiled
-code regardless of which style of local declaration you choose, but the
-Johns-Hopkins syntax is more readable, more flexible, and supports <tt>2LOCAL</tt>s
-- if you agree, then skip this section.&nbsp;
-<p>Ficl includes support for <tt>LOCALS</tt> and <tt>LOCALS EXT</tt> words
-(all three of them!). I've implemented both of the local variable syntaxes
-suggested in DPANS Appendix A.13. Examples: (By the way, Ficl implements
-<tt>-ROT</tt>
-as <tt>: -rot&nbsp;&nbsp; 2 -roll ;</tt> )
-<blockquote><b><tt>\ Using LOCALS| from LOCALS EXT</tt></b>
-<br><b><tt>: -rot&nbsp;&nbsp; ( a b c -- c a b )</tt></b>
-<br><b><tt>&nbsp;&nbsp; locals| c b a |</tt></b>
-<br><b><tt>&nbsp; c a b&nbsp;</tt></b>
-<br><b><tt>;</tt></b></blockquote>
-
-<ul><b><tt>\ Using LOCAL END-LOCAL</tt></b>
-<br><b><tt>: -rot&nbsp;&nbsp; ( a b c -- c a b )</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; local c</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; local b</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; local a</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; end-locals</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; c a b</tt></b>
-<br><b><tt>;</tt></b></ul>
-
-<h2>
-Build Controls</h2>
-Local variable support is optional because it adds a small amount of overhead
-to the outer interpreter. You can disable it by setting FICL_WANT_LOCALS
-to 0 in sysdep.h. Beware: <a href="ficl_oop.html">Ficl's OOP</a> code makes
-heavy use of local variables, so if you disable locals, you're going to
-lose other capabilities too. Local variables can make Forth code quite
-a bit easier to read, so I'd encourage you to experiment with them.&nbsp;
-<p>The default maximum number of local variables is 16. It's controlled
-by FICL_MAX_LOCALS in sysdep.h.&nbsp;
-<h2>
-Release notes for local variables</h2>
-<p>Ficl 2.05 adds 2LOCALS using the "2:" prefix</p>
-<p>Ficl 2.02 includes by default an implementation of the Johns Hopkins local
-syntax (as best I can determine it from examples on the web). This syntax
-lets you declare local variables that look very much like a stack comment.
-Variables in the declaration appear in the "correct" order for a stack
-comment. Everything after the -- is treated as a comment. In addition,
-you can insert a | before the -- to declare one or more zero-initialized
-locals. Example:&nbsp;</p>
-<blockquote><b><tt>:tuck0&nbsp;&nbsp; { a b c | d -- 0 a b c }</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; d a b c ;</tt></b></blockquote>
-The | and -- delimiters can appear at most once, and must appear in the
-order shown in the example to work correctly. The local declaration ends
-at the first occurrence of }. The declaration must all be on one line as
-presently implemented.&nbsp;
-<p><b>Deprecated</b>: Ficl 2.01 added yet another local syntax that models
-a stack comment. This one is not compiled in the release, but you can add
-it by editing softwords/softcore.bat to include the file ficllocal.fr.
-In this case, parameters are re-ordered so that the rightmost initialized
-param comes from the top of the stack. The syntax is:&nbsp;
-<blockquote><b><tt>{{ &lt;initialized params> -- &lt;cleared params> }}</tt></b></blockquote>
-You can omit either the initialized or the cleared parameters. Parameters
-after the double dash are set to zero initially. Those to the left are
-initialized from the stack at execution time. Examples (lame ones, admittedly):&nbsp;
-<br>&nbsp;
-<blockquote>
-<pre><b><tt>: -rot&nbsp;&nbsp; ( a b c -- c a b )
-&nbsp;&nbsp;&nbsp; {{ a b c }}</tt></b>&nbsp;
-&nbsp;&nbsp;&nbsp; <b><tt>c a b&nbsp;</tt></b>&nbsp;
-<b><tt>;</tt></b>&nbsp;
-
-<b><tt>: tuck0&nbsp; ( a b c -- 0 a b c )</tt></b>&nbsp;
-<b><tt>&nbsp;&nbsp;&nbsp; {{ a b c -- d }}</tt></b>&nbsp;
-<b><tt>&nbsp;&nbsp;&nbsp; d a b c&nbsp;</tt></b>&nbsp;
-<b><tt>;&nbsp;</tt></b></pre>
-</blockquote>
-</td>
-</tr>
-</table>
-
-</body>
-</html>
diff --git a/doc/ficl_logo.jpg b/doc/ficl_logo.jpg
deleted file mode 100644
index c3332dbf65a1..000000000000
--- a/doc/ficl_logo.jpg
+++ /dev/null
Binary files differ
diff --git a/doc/ficl_oop.html b/doc/ficl_oop.html
deleted file mode 100644
index 438eaebdcfb2..000000000000
--- a/doc/ficl_oop.html
+++ /dev/null
@@ -1,1387 +0,0 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Author" content="john sadler">
- <meta name="Description" content="object oriented programming in the coolest embedded scripting language ever">
- <meta name="GENERATOR" content="Mozilla/4.73 [en] (Win98; U) [Netscape]">
- <title>Ficl Object Oriented Programming</title>
-</head>
-<body>
-
-<h1>
-<b>Object Oriented Programming in ficl</b></h1>
-
-
-<script language="javascript" src="ficlheader.js"></script>
-
-
-<h2>
-Contents</h2>
-
-<ul>
-<li>
-<a href="#objects">Object Oriented Programming in ficl</a></li>
-
-<li>
-<a href="#ootutorial">Ficl OO Tutorial</a></li>
-
-<li>
-<a href="#cstring">Ficl String Classes</a></li>
-
-<li>
-<a href="ficl.html#oopgloss">OOP glossary</a></li>
-
-<li>
-<a href="#glossinstance">Instance variable glossary</a></li>
-
-<li>
-<a href="#glossclass">Class methods glossary</a></li>
-
-<li>
-<a href="#objectgloss"><tt>OBJECT</tt> base class methods glossary</a></li>
-
-<li>
-<a href="#stockclasses">Supplied Classes</a></li>
-</ul>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h2>
-<a NAME="objects"></a>Object Oriented Programming in ficl</h2>
-
-<h3>
-Review of <a href="http://whatis.techtarget.com/definition/0,289893,sid9_gci212681,00.html">OO</a> ideas</h3>
-Click <a href="oo_in_c.html#review">here</a> for a short review of OO ideas,
-terms, and implementations in other languages, or <a href="http://www.soft-design.com/softinfo/objects.html">here</a>
-for an introduction to the terms and principles of Object Oriented Programming
-<h3>
-Design goals of Ficl OO syntax</h3>
-Ficl's object extensions provide the traditional OO benefits of associating
-data with the code that manipulates it, and reuse through single inheritance.
-Ficl also has some unusual capabilities that support interoperation with
-systems written in C.&nbsp;
-<ul>
-<li>
-Ficl objects are normally late bound for safety (late binding guarantees
-that the appropriate method will always be invoked for a particular object).
-Early binding is also available, provided you know the object's class at
-compile-time.</li>
-
-<li>
-Ficl OOP supports single inheritance, aggregation, and arrays of objects.</li>
-
-<li>
-Classes have independent name spaces for their methods: methods are only
-visible in the context of a class or object. Methods can be overridden
-or added in subclasses; there is no fixed limit on the number of methods
-of a class or subclass.</li>
-
-<li>
-Ficl OOP syntax is regular and unified over classes and objects. In ficl,
-all classes are objects. Class methods include the ability to subclass
-and instantiate.</li>
-
-<li>
-Ficl can adapt legacy data structures with object wrappers. You can model
-a structure in a Ficl class, and create an instance that refers to an address
-in memory that holds an instance of the structure. The <i>ref object</i>
-can then manipulate the structure directly. This lets you wrap data structures
-written and instantiated in C.</li>
-</ul>
-
-<h3>
-Acknowledgements</h3>
-Ficl is not the first Forth to include Object Oriented extensions. Ficl's
-OO syntax owes a debt to the work of John Hayes and Dick Pountain, among
-others. OO Ficl is different from other OO Forths in a few ways, though
-(some things never change). First, unlike several implementations, the
-syntax is documented (<a href="#ootutorial">below</a>) beyond the source
-code. In Ficl's spirit of working with C code, the OO syntax provides means
-to adapt existing data structures. I've tried to make Ficl's OO model simple
-and safe by unifying classes and objects, providing late binding by default,
-and separating namespaces so that methods and regular Forth words are not
-easily confused.&nbsp;</td>
-</tr>
-</table>
-
-<br>&nbsp;
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-Ficl Object Model</h3>
-All classes in Ficl are derived from the common base class <tt><a href="#objectgloss">OBJECT,</a></tt>
-as shown in the <a href="#figure1">figure</a> below. All classes are instances
-of <tt><a href="#glossclass">METACLASS</a></tt>. This means that classes
-are objects, too. <tt>METACLASS</tt> implements the methods for messages
-sent to classes. Class methods create instances and subclasses, and give
-information about the class. Each class is represented by a data stucture
-of three elements:&nbsp;
-<ul>
-<li>
-The address (named <tt>.CLASS</tt> ) of a parent class, or zero if it's
-a base class (only <tt>OBJECT</tt> and <tt>METACLASS</tt> have this property)</li>
-
-<li>
-The size (named <tt>.SIZE</tt> ) in address units of an instance of the
-class</li>
-
-<li>
-A wordlist ID (named <tt>.WID</tt> ) for the methods of the class</li>
-</ul>
-In the figure below, <tt>METACLASS</tt> and <tt>OBJECT</tt> are real system-supplied
-classes. The others are contrived to illustrate the relationships among
-derived classes, instances, and the two system base classes. The dashed
-line with an arrow at the end indicates that the object/class at the arrow
-end is an instance of the class at the other end. The vertical line with
-a triangle denotes inheritance.&nbsp;
-<p>Note for the curious: <tt>METACLASS</tt> behaves like a class - it responds
-to class messages and has the same properties as any other class. If you
-want to twist your brain in knots, you can think of <tt>METACLASS</tt>
-as an instance of itself.&nbsp;
-<br>&nbsp;</td>
-</tr>
-</table>
-
-<p><a NAME="figure1"></a><img SRC="ficl_oop.jpg" VSPACE=10 height=442 width=652>
-<br>&nbsp;
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h2>
-<a NAME="ootutorial"></a>Ficl OO Syntax Tutorial</h2>
-
-<h3>
-Introduction</h3>
-It's helpful to have some familiarity with Forth and the customary Forth
-stack notation to understand this tutorial. To get started, take a look
-at this <a href="http://www.taygeta.com/forth_intro/stackflo.html">web-based
-Forth tutorial</a>. If you're comfortable with both OO and Forth, you can
-<a href="#ootutorial-finally">jump
-ahead</a>.
-<p>A Ficl <a href="oo_in_c.html#object-def">object</a> associates a <a href="oo_in_c.html#class-def">class</a>
-with an <a href="oo_in_c.html#instance-def">instance</a> (the storage for
-one set of instance variables). This is done explicitly on Ficl's stack,
-in that any Ficl object is represented by a cell pair:&nbsp;
-<blockquote><b><tt>( instance-addr class-addr )</tt></b></blockquote>
-The instance-addr is the address of the object's storage, and the class-addr
-is the address of its class. Whenever a named Ficl object executes (eg.
-when you type its name and press enter at the Ficl prompt), it leaves this
-"signature". All methods by convention expect a class and instance on the
-stack when they execute, too. In many other OO languages, including C++,
-instances contain information about their classes (a <a href="http://www.mvps.org/vbvision/vtable.htm">vtable</a>
-pointer, for example). By making this pairing explicit rather than implicit,
-Ficl can be OO about chunks of data that don't realize that they are objects,
-without sacrificing any robustness for native objects. That means that
-you can use Ficl to write object wrappers for data structures created in
-C or assembly language, as long as you can determine how they're laid out
-in memory.&nbsp;
-<br>Whenever&nbsp; you create an object in Ficl, you specify its class.
-After that, the object always pushes its class and the address of its <a href="http://www.aware.com/Glossary/main.htm#P">payload
-</a>(instance
-variable space) when invoked by name.&nbsp;
-<p>Classes are special kinds of objects that store the methods of their
-instances, the size of an instance's payload, and a parent class pointer.
-Classes themselves are instances of a special base class called <tt>METACLASS</tt>,
-and all classes inherit from class <tt>OBJECT</tt>. This is confusing at
-first, but it means that Ficl has a very simple syntax for constructing
-and using objects. Class methods include subclassing (<tt>SUB</tt>), creating
-initialized and uninitialized instances (<tt>NEW</tt> and <tt>INSTANCE</tt>),
-and creating reference instances (<tt>REF</tt>), described later. Classes
-also have methods for disassembling their methods (<tt>SEE</tt>), identifying
-themselves (<tt>ID</tt>), and listing their pedigree (<tt>PEDIGREE</tt>).
-All objects inherit (from <tt>OBJECT</tt>) methods for initializing instances
-and arrays of instances, for performing array operations, and for getting
-information about themselves.&nbsp;
-<h3>
-Methods and messages</h3>
-Methods are the functions that objects execute in response to messages.
-A message is a request to an object for a behavior that the object supports.
-When it receives a message, the target object looks up a method that performs
-the behavior for its class, and executes it. Any specific message may be
-bound to different methods in different objects, according to class. This
-separation of messages and methods allows objects to behave <a href="http://www.whatis.com/polymorp.htm">polymorphically</a>.
-(In Ficl, methods are words defined in the context of a class, and messages
-are the names of those words.) Ficl classes associate messages with methods
-for their instances (a fancy way of saying that each class owns a wordlist).
-Ficl provides a late-binding operator <b><tt>--></tt></b> that sends messages
-to objects at run-time, and an early-binding operator <b><tt>=></tt></b>
-that compiles a specific class's method. These operators are the only supported
-way to invoke methods. Regular Forth words are not visible to the method-binding
-operators,&nbsp; so there's no chance of confusing a message with a regular
-word of the same name.&nbsp;</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-<a NAME="ootutorial-finally"></a>Tutorial (finally!)</h3>
-This is a tutorial. It works best if you follow along by pasting the examples
-into ficlWin, the Win32 version of Ficl included with the release sources
-(or some other build that includes the OO part of softcore.c). If you're
-not familiar with Forth, please see one of these <a href="#links">references</a>.
-Ficl's OOP words are in vocabulary <tt>OOP</tt>. To put <tt>OOP</tt> in
-the search order and make it the compilation wordlist, type:&nbsp;
-<pre>
-ONLY ( reset to default search order )
-ALSO OOP DEFINITIONS
-</pre>
-(<b>Note for beginners</b>: to see the effect of the commands above, type
-<tt>ORDER</tt>
-after each line. You can repeat the sequence above if you like.)
-<p>To start, we'll work with the two base classes <tt>OBJECT</tt> and <tt>METACLASS</tt>.
-Try this:&nbsp;
-<pre>
-metaclass --> methods
-</pre>
-The line above contains three words. The first is the name of a class,
-so it pushes its signature on the stack. Since all classes are instances
-of <tt>METACLASS</tt>, <tt>METACLASS</tt> behaves as if it is an instance
-of itself (this is the only class with this property). It pushes the same
-address twice: once for the class and once for the payload, since they
-are the same. The next word finds a method in the context of a class and
-executes it. In this case, the name of the method is <tt>methods</tt>.
-Its job is to list all the methods that a class knows. What you get when
-you execute this line is a list of all the class methods Ficl provides.&nbsp;
-<pre>
-object --> sub c-led
-</pre>
-Causes base-class <tt>OBJECT</tt> to derive from itself a new class called
-c-led. Now we'll add some instance variables and methods to the new class...&nbsp;
-<br><b>Note</b>: I like to prefix the names of classes with "c-", and the
-names of member variables with a dot, but this is just a convention. If
-you don't like it, you can pick your own.
-<pre>
-c-byte obj: .state
-: init { 2:this -- }
- this --> super --> init
- ." initializing an instance of "
- this --> class --> id type cr ;
-: on { led# 2:this -- }
- this --> .state --> get
- 1 led# lshift or dup !oreg
- this --> .state --> set ;
-: off { led# 2:this -- }
- this --> .state --> get
- 1 led# lshift invert and dup !oreg
- this --> .state --> set&nbsp; ;
-end-class
-</pre>
-The first line adds an instance variable called <tt>.state</tt> to the
-class. This particular instance variable is an object - it will be an instance
-of c-byte, one of ficl's stock classes (the source for which can be found
-in the distribution in sorftowrds/classes.fr).&nbsp;
-<br>Next we've defined a method called <tt>init</tt>. This line also declares
-a <a href="ficl_loc.html">local variable</a> called <b><tt>this</tt></b>
-(the 2 in front tells Ficl that this is a double-cell local). All methods
-by convention expect the address of the class and instance on top of the
-stack when called.&nbsp; The next three lines define <tt>init</tt>'s behavior.
-It first calls its superclass's version of <tt>init</tt> (which in this
-case is <tt>object => init</tt> - this default implementation clears all
-instance variables). The rest displays some text and causes the instance
-to print its class name (<tt>this --> class --> id</tt>).
-<br>The <b><tt>init</tt></b> method is special for Ficl objects: whenever
-you create an initialized instance using <b><tt>new</tt></b> or <b><tt>new-array</tt></b>,
-Ficl calls the class's <tt>init</tt> method for you on that instance. The
-default <tt>init</tt> method supplied by <tt>object</tt> clears the instance,
-so we didn't really need to override it in this case (see the source code
-in ficl/softwords/oo.fr).&nbsp;
-<br>The <tt>ON</tt> and <tt>OFF</tt> methods defined above hide the details
-of turning LEDs on and off. The interface to FiclWin's simulated hardware
-is handled by <tt>!OREG</tt>. The class keeps the LED state in a shadow
-variable (<tt>.STATE</tt>) so that <tt>ON</tt> and <tt>OFF</tt> can work
-in terms of LED number rather than a bitmask.
-<p>Now make an instance of the new class:&nbsp;
-<pre>
-c-led --> new led
-</pre>
-And try a few things...&nbsp;
-<pre>
-led --> methods
-led --> pedigree
-1 led --> on
-1 led --> off
-</pre>
-Or you could type this with the same effect:&nbsp;
-<pre>
-led 2dup --> methods --> pedigree
-</pre>
-Notice (from the output of <tt>methods</tt>) that we've overridden the
-init method supplied by object, and added two more methods for the member
-variables. If you type <tt>WORDS</tt>, you'll see that these methods are
-not visible outside the context of the class that contains them. The method
-finder <b><tt>--></tt></b> uses the class to look up methods. You can use
-this word in a definition, as we did in <tt>init</tt>, and it performs
-late binding, meaning that the mapping from message (method name) to method
-(the code) is deferred until run-time. To see this, you can decompile the
-init method like this:&nbsp;
-<pre>
-c-led --> see init
-</pre>
-or
-<pre>
-led --> class --> see init
-</pre>
-
-<h3>
-Early binding</h3>
-Ficl also provides early binding if you ask for it. Early binding is not
-as safe as late binding, but it produces code that is more compact and
-efficient because it compiles method addresses rather then their names.
-In the preferred uses of early binding, the class is assumed to be the
-one you're defining. This kind of early binding can only be used inside
-a class definition. Early bound methods still expect to find a class and
-instance cell-pair on top of the stack when they run.
-<br>Here's an example that illustrates a potential problem:
-<pre>
-object --> sub c1
-: m1 { 2:this -- } ." c1's m1" cr ;
-: m2 { 2:this -- } ." Running " this my=> m1 ; ( early )
-: m3 { 2:this -- } ." Running " this --> m1 ( late )
-end-class
-c1 --> sub c2
-: m1 { 2:this -- } ." c2's m1" cr ;
-end-class
-c2 --> new i2
-i2 --> m1 ( runs the m1 defined in c2 )
-i2 --> m2 ( is this what you wanted? )
-i2 --> m3 { runs the overridden m1)
-</pre>
-Even though we overrode method m1 in class c2, the definition of m2 with
-early binding forced the use of m1 as defined in c1. If that's what you
-want, great, but more often you'll want the flexibility of overriding parent
-class behaviors appropriately.&nbsp;
-<ol>
-<li>
-<code>my=></code> binds early to a method in the class being defined,
-as in the example above.
-</li>
-<li>
-<code>my=[ ]</code> binds a sequence of methods in the current class.
-Useful when the class has object members. Lines like <code>this --> state
---> set</code> in the definition of c-led above can be replaced with
-<code>this my=[ state set ]</code> to get early binding.
-</li>
-<li>
-<code>=></code> (dangerous) pops a class off the stack and compiles
-the method in that class. Since you have to specify the class explicitly,
-there is a real danger that this will be out of sync with the class you
-really wanted. I recommend the <code>my=</code> operations.
-</li>
-</ol>
-Early binding using <code>=></code> is dangerous because it partially
-defeats the data-to-code matching mechanism object oriented languages were
-created to provide, but it does increase run-time speed by binding the
-method at compile time. In many cases, such as the <code>init</code> method,
-you can be reasonably certain of the class of thing you're working on.
-This is also true when invoking class methods, since all classes are instances
-of <code>metaclass</code>. Here's an example from the definition of <code>metaclass</code>
-in oo.fr (don't paste this into ficlWin - it's already there):
-<pre>
-: new \ ( class metaclass "name" -- )
- metaclass => instance --> init ;
-</pre>
-Try this...
-<pre>
-metaclass --> see new
-</pre>
-Decompiling the method with <code>SEE</code> shows the difference between the
-two strategies. The early bound method is compiled inline, while the late-binding
-operator compiles the method name and code to find and execute it in the
-context of whatever class is supplied on the stack at run-time.
-<br>Notice that the primitive early-binding operator <code>=></code> requires
-a class at compile time. For this reason, classes are <code>IMMEDIATE</code>,
-meaning that they push their signature at compile time or run time. I'd
-recommend that you avoid early binding until you're very comfortable with
-Forth, object-oriented programming, and Ficl's OOP syntax.
-<br>
-<h3>
-More About Instance Variables</h3>
-<i>Untyped</i> instance variable methods (created by <tt>cell: cells: char:</tt>
-and <tt>chars:</tt>) just push the address of the corresponding instance
-variable when invoked on an instance of the class. It's up to you to remember
-the size of the instance variable and manipulate it with the usual Forth
-words for fetching and storing.&nbsp;
-<p>As advertised earlier, Ficl provides ways to objectify existing data
-structures without changing them. Instead, you can create a Ficl class
-that models the structure, and instantiate a <b>ref </b>from this class,
-supplying the address of the structure. After that, the <i>ref instance</i>
-behaves as a Ficl object, but its instance variables take on the values
-in the existing structure. Example (from ficlclass.fr):&nbsp;
-<blockquote><b><tt>object subclass c-wordlist</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; c-wordlist ref: .parent</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; c-ptr&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; obj:
-.name</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; c-cell&nbsp;&nbsp;&nbsp;&nbsp; obj: .size</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; c-word&nbsp;&nbsp;&nbsp;&nbsp; ref: .hash</tt></b>
-<p><b><tt>&nbsp;&nbsp;&nbsp; : ?</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 2drop ." ficl wordlist
-" cr ;</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; : push&nbsp; drop&nbsp; >search ;</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; : pop&nbsp;&nbsp; 2drop previous ;</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; : set-current&nbsp;&nbsp; drop set-current
-;</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; : words&nbsp;&nbsp; --> push&nbsp; words
-previous ;</tt></b>
-<br><b><tt>end-class</tt></b></blockquote>
-In this case, <tt>c-wordlist</tt> describes Ficl's wordlist structure;
-named-wid creates a wordlist and binds it to a ref instance of <tt>c-wordlist</tt>.
-The fancy footwork with <tt>POSTPONE</tt> and early binding is required
-because classes are immediate. An equivalent way to define named-wid with
-late binding is:&nbsp;
-<blockquote><b><tt>: named-wid&nbsp;&nbsp; ( "name" -- )</tt></b>
-<br><b><tt>&nbsp;&nbsp;&nbsp; wordlist&nbsp; postpone c-wordlist&nbsp;
---> ref ;</tt></b></blockquote>
-To do the same thing at run-time (and call it my-wordlist):&nbsp;
-<blockquote><b><tt>wordlist&nbsp; c-wordlist --> ref&nbsp; my-wordlist</tt></b></blockquote>
-Now you can deal with the wordlist through the ref instance:&nbsp;
-<blockquote><b><tt>my-wordlist --> push</tt></b>
-<br><b><tt>my-wordlist --> set-current</tt></b>
-<br><b><tt>order</tt></b></blockquote>
-Ficl can also model linked lists and other structures that contain pointers
-to structures of the same or different types. The class constructor word
-<b><tt><a href="#exampleref:">ref:</a></tt></b>
-makes an aggregate reference to a particular class. See the <a href="#glossinstance">instance
-variable glossary</a> for an <a href="#exampleref:">example</a>.&nbsp;
-<p>Ficl can make arrays of instances, and aggregate arrays into class descripions.
-The <a href="#glossclass">class methods</a> <b><tt>array</tt></b> and <b><tt>new-array</tt></b>
-create uninitialized and initialized arrays, respectively, of a class.
-In order to initialize an array, the class must define (or inherit) a reasonable
-<b><tt>init</tt></b>
-method. <b><tt>New-array</tt></b> invokes it on each member of the array
-in sequence from lowest to highest. Array instances and array members use
-the object methods <b><tt>index</tt></b>, <b><tt>next</tt></b>, and <b><tt>prev</tt></b>
-to navigate. Aggregate a member array of objects using <b><tt><a href="#arraycolon">array:</a></tt></b>.
-The objects are not automatically initialized in this case - your class
-initializer has to call <b><tt>array-init</tt></b> explicitly if you want
-this behavior.&nbsp;
-<p>For further examples of OOP in Ficl, please see the source file ficl/softwords/ficlclass.fr.
-This file wraps several Ficl internal data structures in objects and gives
-use examples.&nbsp;</td>
-</tr>
-
-<tr>
-<td>
-<h2>
-<a NAME="cstring"></a>Ficl String classes</h2>
-c-string (ficl 2.04 and later) is a reasonably useful dynamic string class.
-Source code for the class is located in ficl/softwords/string.fr. Features:
-dynamic creation and resizing; deletion, char cout, concatenation, output,
-comparison; creation from quoted string constant (s").
-<p>Examples of use:
-<blockquote>
-<pre><b>c-string --> new homer
-s" In this house, " homer --> set
-s" we obey the laws of thermodynamics!" homer --> cat
-homer --> type</b></pre>
-</blockquote>
-</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h2>
-<a NAME="oopgloss"></a>OOP Glossary</h2>
-Note: with the exception of the binding operators (the first two definitions
-here), all of the words in this section are internal factors that you don't
-need to worry about. These words provide method binding for all classes
-and instances. Also described are supporting words and execution factors.
-All are defined in softwords/oo.fr.&nbsp;
-<dl>
-<dt>
-<b><tt>-->&nbsp;&nbsp; ( instance class "method-name" -- xn )</tt></b></dt>
-
-<dd>
-Late binding: looks up and executes the given method in the context of
-the class on top of the stack.&nbsp;</dd>
-
-<dt>
-<b><tt>c->&nbsp;&nbsp; ( instance class "method-name" -- xn exc )</tt></b></dt>
-
-<dd>
-Late binding with <tt>CATCH</tt>: looks up and <tt>CATCH</tt>es the given
-method in the context of the class on top of the stack, pushes zero or
-exception code upon return.</dd>
-
-<dt>
-<b><tt>my=> comp: ( "method-name" -- )&nbsp; exec: ( inst class -- xn )</tt></b></dt>
-
-<dd>
-Early binding: compiles code to execute the method of the class being defined.
-Only visible and valid in the scope of a <tt>--> sub</tt> .. <tt>end-class</tt>
-class definition.</dd>
-
-<dt>
-<b><tt>my=[ comp: ( "obj1 obj2 .. method ]" -- ) exec:( inst class -- xn
-)</tt></b></dt>
-
-<dd>
-Early binding: compiles code to execute a chain of methods of the class
-being defined. Only visible and valid in the scope of a <tt>--> sub</tt>
-.. <tt>end-class</tt> class definition.</dd>
-
-<dt>
-<b><tt>=>&nbsp;&nbsp; comp: ( class meta "method-name" -- )&nbsp; exec:
-( inst class -- xn )</tt></b></dt>
-
-<dd>
-Early binding: compiles code to execute the method of the class specified
-at compile time.</dd>
-
-<dt>
-<b><tt>do-do-instance</tt></b></dt>
-
-<dd>
-When executed, causes the instance to push its ( instance class ) stack
-signature. Implementation factor of <b><tt>metaclass --> sub</tt></b>.
-Compiles <b><tt>.do-instance</tt></b> in the context of a class; <tt>.do-instance</tt>
-implements the <tt>does></tt> part of a named instance.&nbsp;</dd>
-
-<dt>
-<b><tt>exec-method&nbsp;&nbsp; ( instance class c-addr u -- xn )</tt></b></dt>
-
-<dd>
-Given the address and length of a message (method name) on the stack, finds
-the method in the context of the specified class and invokes it. Upon entry
-to the method, the instance and class are on top of the stack, as usual.
-If unable to find the method, prints an error message and aborts.</dd>
-
-<dt>
-<b><tt>find-method-xt&nbsp;&nbsp; ( class "method-name" -- class xt )</tt></b></dt>
-
-<dd>
-Attempts to map the message to a method in the specified class. If successful,
-leaves the class and the execution token of the method on the stack. Otherwise
-prints an error message and aborts.</dd>
-
-<dt>
-<b><tt>lookup-method&nbsp;&nbsp; ( class c-addr u -- class xt )</tt></b></dt>
-
-<dd>
-Given the address and length of a message (method name) on the stack, finds
-the method in the context of the specified class. If unable to find the
-method, prints an error message and aborts.</dd>
-
-<dt>
-<b><tt>parse-method&nbsp;&nbsp; comp: ( "method-name" -- )&nbsp; exec:
-( -- c-addr u )</tt></b></dt>
-
-<dd>
-Parse "name" from the input stream and compile code to push its length
-and address when the enclosing definition runs.</dd>
-</dl>
-</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-<a NAME="glossinstance"></a>Instance Variable Glossary</h3>
-<b>Note</b>: these words are only visible when creating a subclass! To
-create a subclass, use the <tt>sub</tt> method on <tt>object</tt> or any
-class derived from it (<i>not</i> <tt>metaclass</tt>). Source code for
-Ficl OOP is in ficl/softwords/oo.fr.&nbsp;
-<br>Instance variable words do two things: they create methods that do
-an action appropriate for the type of instance variable they represent,
-and they reserve space in the class template for the instance variable.
-We'll use the term <i>instance variable</i> to refer both to the method
-that gives access to a particular field of an object, and to the field
-itself. Rather than give esentially the same example over and over, here's
-one example that shows several of the instance variable construction words
-in use:
-<blockquote><tt>object subclass c-example</tt>
-<br><tt>&nbsp;&nbsp; cell:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-.cell0</tt>
-<br><tt>&nbsp;&nbsp; c-4byte&nbsp;&nbsp; obj: .nCells</tt>
-<br><tt>&nbsp;4 c-4byte array: .quad</tt>
-<br><tt>&nbsp;&nbsp; char:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-.length</tt>
-<br><tt>79 chars:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; .name</tt>
-<br><tt>end-class</tt>&nbsp;</blockquote>
-This class only defines instance variables, and it inherits some methods
-from <tt>object</tt>. Each untyped instance variable (.cell0, .length,
-.name) pushes its address when executed. Each object instance variable
-pushes the address and class of the aggregate object. Similar to C, an
-array instance variable leaves its base address (and its class) when executed.
-The word <tt>subclass</tt> is shorthand for "<tt>--> sub</tt>"&nbsp;
-<dl>
-<dt>
-<b><font face="Courier New"><font size=-1>cell:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-( offset "name" -- offset' )</font></font></b></dt>
-
-<dt>
-<b><font face="Courier New"><font size=-1>Execution:&nbsp; ( -- cell-addr
-)</font></font></b></dt>
-
-<dd>
-Create an untyped instance variable one cell wide. The instance variable
-leaves its payload's address when executed.&nbsp;</dd>
-
-<dt>
-<b><tt>cells:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( offset nCells "name"
--- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- cell-addr )</tt></b></dt>
-
-<dd>
-Create an untyped instance variable n cells wide.</dd>
-
-<dt>
-<b><tt>char:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( offset "name"
--- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- char-addr )</tt></b></dt>
-
-<dd>
-Create an untyped member variable one char wide</dd>
-
-<dt>
-<b><tt>chars:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( offset nChars "name"
--- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- char-addr )</tt></b></dt>
-
-<dd>
-Create an untyped member variable n chars wide.</dd>
-
-<dt>
-<b><tt>obj:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( offset class
-meta "name" -- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- instance class )</tt></b></dt>
-
-<dd>
-Aggregate an uninitialized instance of <b>class</b> as a member variable
-of the class under construction.</dd>
-
-<dt>
-<a NAME="arraycolon"></a><b><tt>array:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-( offset n class meta "name" -- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- instance class )</tt></b></dt>
-
-<dd>
-Aggregate an uninitialized array of instances of the class specified as
-a member variable of the class under construction.</dd>
-
-<dt>
-<a NAME="exampleref:"></a><b><tt>ref:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-( offset class meta "name" -- offset' )</tt></b></dt>
-
-<dt>
-<b><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-Execution:&nbsp; ( -- ref-instance ref-class )</tt></b></dt>
-
-<dd>
-Aggregate a reference to a class instance. There is no way to set the value
-of an aggregated ref - it's meant as a way to manipulate existing data
-structures with a Ficl OO model. For example, if your system contains a
-linked list of 4 byte quantities, you can make a class that represents
-a list element like this:&nbsp;</dd>
-
-<dl>
-<dd>
-<tt>object subclass c-4list</tt></dd>
-
-<dd>
-<tt>c-4list ref: .link</tt></dd>
-
-<dd>
-<tt>c-4byte obj: .payload</tt></dd>
-
-<dd>
-<tt>end-class;</tt></dd>
-
-<dd>
-<tt>address-of-existing-list c-4list --> ref mylist</tt></dd>
-</dl>
-
-<dd>
-The last line binds the existing structure to an instance of the class
-we just created. The link method pushes the link value and the class c_4list,
-so that the link looks like an object to Ficl and like a struct to C (it
-doesn't carry any extra baggage for the object model - the Ficl methods
-alone take care of storing the class information).&nbsp;</dd>
-
-<dd>
-Note: Since a ref: aggregate can only support one class, it's good for
-modeling static structures, but not appropriate for polymorphism. If you
-want polymorphism, aggregate a c_ref (see classes.fr for source) into your
-class - it has methods to set and get an object.</dd>
-
-<dd>
-By the way, it is also possible to construct a pair of classes that contain
-aggregate pointers to each other. Here's an example:</dd>
-
-<dl>
-<dd>
-<tt>object subclass akbar</tt></dd>
-
-<dd>
-<tt>suspend-class&nbsp;&nbsp;&nbsp;&nbsp; \ put akbar on hold while we
-define jeff</tt></dd>
-
-<dd>
-<tt>object subclass jeff</tt></dd>
-
-<dd>
-<tt>&nbsp;&nbsp;&nbsp; akbar ref: .significant-other</tt></dd>
-
-<dd>
-<tt>&nbsp;&nbsp;&nbsp; ( your additional methods here )</tt></dd>
-
-<dd>
-<tt>end-class&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; \ done with
-jeff</tt></dd>
-
-<dd>
-<tt>akbar --> resume-class&nbsp; \ resume defining akbar</tt></dd>
-
-<dd>
-<tt>&nbsp;&nbsp;&nbsp; jeff ref: .significant-other</tt></dd>
-
-<dd>
-<tt>&nbsp;&nbsp;&nbsp; ( your additional methods here )</tt></dd>
-
-<dl><tt>end-class&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; \ done
-with akbar</tt></dl>
-</dl>
-</dl>
-</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-<a NAME="glossclass"></a>Class Methods Glossary</h3>
-These words are methods of <tt>metaclass</tt>. They define the manipulations
-that can be performed on classes. Methods include various kinds of instantiation,
-programming tools, and access to member variables of classes. Source is
-in softwords/oo.fr.&nbsp;
-<dl>
-<dt>
-<b><tt>instance&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass "name" -- instance
-class )</tt></b>&nbsp;</dt>
-
-<dd>
-Create an uninitialized instance of the class, giving it the name specified.
-The method leaves the instance 's signature on the stack (handy if you
-want to initialize). Example:</dd>
-
-<dd>
-<tt>c_ref --> instance uninit-ref&nbsp; 2drop</tt></dd>
-
-<dt>
-<b><tt>new&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class
-metaclass "name" -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Create an initialized instance of class, giving it the name specified.
-This method calls init to perform initialization.&nbsp;</dd>
-
-<dt>
-<b><tt>array&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( nObj class metaclass
-"name" -- nObjs instance class )</tt></b>&nbsp;</dt>
-
-<dd>
-Create an array of nObj instances of the specified class. Instances are
-not initialized. Example:</dd>
-
-<dd>
-<tt>10 c_4byte --> array&nbsp; 40-raw-bytes&nbsp; 2drop drop</tt></dd>
-
-<dt>
-<b><tt>new-array&nbsp;&nbsp;&nbsp; ( nObj class metaclass "name" -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Creates an initialized array of nObj instances of the class. Same syntax
-as <tt>array</tt></dd>
-
-<dt>
-<a NAME="alloc"></a><b><tt>alloc&nbsp;&nbsp; ( class metaclass -- instance
-class )</tt></b></dt>
-
-<dd>
-Creates an anonymous instance of <b>class</b> from the heap (using a call
-to ficlMalloc() to get the memory). Leaves the payload and class addresses
-on the stack. Usage example:</dd>
-
-<dd>
-<tt>c-ref --> alloc&nbsp; 2constant instance-of-ref</tt></dd>
-
-<dd>
-Creates a double-cell constant that pushes the payload and class address
-of a heap instance of c-ref.</dd>
-
-<dt>
-<a NAME="allocarray"></a><b><tt>alloc-array&nbsp;&nbsp; ( nObj class metaclass
--- instance class )</tt></b></dt>
-
-<dd>
-Same as new-array, but creates anonymous instances from the heap using
-a call to ficlMalloc(). Each instance is initialized using the class's
-<tt>init</tt>
-method</dd>
-
-<dt>
-<a NAME="allot"></a><b><tt>allot&nbsp;&nbsp; ( class metaclass -- instance
-class )</tt></b></dt>
-
-<dd>
-Creates an anonymous instance of <b>class</b> from the dictionary. Leaves
-the payload and class addresses on the stack. Usage example:</dd>
-
-<dd>
-<tt>c-ref --> allot&nbsp; 2constant instance-of-ref</tt></dd>
-
-<dd>
-Creates a double-cell constant that pushes the payload and class address
-of a heap instance of c-ref.</dd>
-
-<dt>
-<a NAME="allotarray"></a><b><tt>allot-array&nbsp;&nbsp; ( nObj class metaclass
--- instance class )</tt></b></dt>
-
-<dd>
-Same as new-array, but creates anonymous instances from the dictionary.
-Each instance is initialized using the class's
-<tt>init</tt> method</dd>
-
-<dt>
-<b><tt>ref&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance-addr
-class metaclass "name" -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Make a ref instance of the class that points to the supplied instance address.
-No new instance space is allotted. Instead, the instance refers to the
-address supplied on the stack forever afterward. For wrapping existing
-structures.</dd>
-</dl>
-
-<dl>
-<dt>
-<b><tt>sub&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class
-metaclass -- old-wid addr[size] size )</tt></b></dt>
-
-<dd>
-Derive a subclass. You can add or override methods, and add instance variables.
-Alias: <tt>subclass</tt>. Examples:</dd>
-
-<dl>
-<dd>
-<tt>c_4byte --> sub c_special4byte</tt></dd>
-
-<dd>
-<tt>( your new methods and instance variables here )</tt></dd>
-
-<dd>
-<tt>end-class</tt></dd>
-
-<dd>
-or</dd>
-
-<dd>
-<tt>c_4byte subclass c_special4byte</tt></dd>
-
-<dd>
-<tt>( your new methods and instance variables here )</tt></dd>
-
-<dd>
-<tt>end-class</tt></dd>
-</dl>
-
-<dt>
-<b><tt>.size&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass
--- instance-size )</tt></b>&nbsp;</dt>
-
-<dd>
-Returns address of the class's instance size field, in address units. This
-is a metaclass member variable.</dd>
-
-<dt>
-<b><tt>.super&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass --
-superclass )</tt></b>&nbsp;</dt>
-
-<dd>
-Returns address of the class's superclass field. This is a metaclass member
-variable.</dd>
-
-<dt>
-<b><tt>.wid&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass
--- wid )</tt></b>&nbsp;</dt>
-
-<dd>
-Returns the address of the class's wordlist ID field. This is a metaclass
-member variable.</dd>
-
-<dt>
-<b><tt>get-size</tt></b></dt>
-
-<dd>
-Returns the size of an instance of the class in address units. Imeplemented
-as</dd>
-
-<dd>
-<tt>: get-size&nbsp;&nbsp; metaclass => .size @ ;</tt></dd>
-
-<dt>
-<b><tt>get-wid</tt></b></dt>
-
-<dd>
-Returns the wordlist ID of the class. Implemented as&nbsp;</dd>
-
-<dd>
-<tt>: get-wid&nbsp;&nbsp; metaclass => .wid @ ;</tt></dd>
-
-<dt>
-<b><tt>get-super</tt></b></dt>
-
-<dd>
-Returns the class's superclass. Implemented as</dd>
-
-<dd>
-<tt>: get-super&nbsp;&nbsp; metaclass => .super @ ;</tt></dd>
-
-<dt>
-<b><tt>id&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (
-class metaclass -- c-addr u )</tt></b>&nbsp;</dt>
-
-<dd>
-Returns the address and length of a string that names the class.</dd>
-
-<dt>
-<b><tt>methods&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Lists methods of the class and all its superclasses</dd>
-
-<dt>
-<b><tt>offset-of&nbsp;&nbsp;&nbsp; ( class metaclass "name" -- offset )</tt></b></dt>
-
-<dd>
-Pushes the offset from the instance base address of the named member variable.
-If the name is not that of an instance variable method, you get garbage.
-There is presently no way to detect this error. Example:</dd>
-
-<dl>
-<dd>
-<tt>metaclass --> offset-of .wid</tt></dd>
-</dl>
-
-<dt>
-<b><tt>pedigree&nbsp;&nbsp;&nbsp;&nbsp; ( class metaclass -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Lists the pedigree of the class (inheritance trail)</dd>
-
-<dt>
-<b><tt>see&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( class
-metaclass "name" -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Decompiles the specified method - obect version of <tt>SEE</tt>, from the
-<tt>TOOLS</tt>
-wordset.</dd>
-</dl>
-</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-<a NAME="objectgloss"></a><tt>object</tt> base-class Methods Glossary</h3>
-These are methods that are defined for all instances by the base class
-<tt>object</tt>.
-The methods include default initialization, array manipulations, aliases
-of class methods, upcasting, and programming tools.&nbsp;
-<dl>
-<dt>
-<b><tt>init&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance
-class -- )</tt>&nbsp;</b></dt>
-
-<dd>
-Default initializer called automatically for all instances created with
-<tt>new</tt>
-or <tt>new-array</tt>. Zero-fills the instance. You do not normally need
-to invoke <tt>init</tt> explicitly.</dd>
-
-<dt>
-<b><tt>array-init&nbsp;&nbsp; ( nObj instance class -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Applies <tt>init</tt> to an array of objects created by <tt>new-array</tt>.
-Note that <tt>array:</tt> does not cause aggregate arrays to be initialized
-automatically. You do not normally need to invoke <tt>array-init</tt> explicitly.</dd>
-
-<dt>
-<a NAME="oofree"></a><b><tt>free&nbsp;&nbsp; ( instance class -- )</tt></b></dt>
-
-<dd>
-Releases memory used by an instance previously created with <tt>alloc</tt>
-or <tt>alloc-array</tt>. Note - this method is not presently protected
-against accidentally deleting something from the dictionary. If you do
-this, Bad Things are likely to happen. Be careful for the moment to apply
-free only to instances created with <tt>alloc</tt> or <tt>alloc-array</tt>.</dd>
-
-<dt>
-<b><tt>class&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance class
--- class metaclass )</tt></b>&nbsp;</dt>
-
-<dd>
-Convert an object signature into that of its class. Useful for calling
-class methods that have no object aliases.</dd>
-
-<dt>
-<b><tt>super&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance class
--- instance parent-class )</tt></b>&nbsp;</dt>
-
-<dd>
-Upcast an object to its parent class. The parent class of <tt>object</tt>
-is zero. Useful for invoking an overridden parent class method.</dd>
-
-<dt>
-<b><tt>pedigree&nbsp;&nbsp;&nbsp;&nbsp; ( instance class -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Display an object's pedigree - its chain of inheritance. This is an alias
-for the corresponding class method.</dd>
-
-<dt>
-<b><tt>size&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance
-class -- sizeof(instance) )</tt></b>&nbsp;</dt>
-
-<dd>
-Returns the size, in address units, of one instance. Does not know about
-arrays! This is an alias for the class method <tt>get-size</tt></dd>
-
-<dt>
-<b><tt>methods&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance class -- )</tt></b>&nbsp;</dt>
-
-<dd>
-Class method alias. Displays the list of methods of the class and all superclasses
-of the instance.</dd>
-
-<dt>
-<b><tt>index&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( n instance class
--- instance[n] class )</tt></b>&nbsp;</dt>
-
-<dd>
-Convert array-of-objects base signature into signature for array element
-n. No check for bounds overflow. Index is zero-based, like C, so&nbsp;</dd>
-
-<dl>
-<dd>
-<tt>0 my-obj --> index</tt>&nbsp;</dd>
-</dl>
-
-<dd>
-is equivalent to&nbsp;</dd>
-
-<dl>
-<dd>
-<tt>my-obj</tt></dd>
-</dl>
-
-<dd>
-Check out the <a href="#minusrot">description of <tt>-ROT</tt></a> for
-help in dealing with indices on the stack.</dd>
-
-<dt>
-<b><tt>next&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance[n]
-class -- instance[n+1] class )</tt></b>&nbsp;</dt>
-
-<dd>
-Convert an array-object signature&nbsp; into the signature of the next
-object in the array. No check for bounds overflow.</dd>
-
-<dt>
-<b><tt>prev&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ( instance[n]
-class -- instance[n-1] class )</tt></b>&nbsp;</dt>
-
-<br>Convert an object signature into the signature of the previous object
-in the array. No check for bounds underflow.</dl>
-</td>
-</tr>
-</table>
-
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
-<h3>
-<a NAME="stockclasses"></a>Supplied Classes (See classes.fr)</h3>
-
-<dl>
-<dt>
-<b><tt>metaclass&nbsp;</tt></b></dt>
-
-<dd>
-Describes all classes of Ficl. Contains class methods. Should never be
-directly instantiated or subclassed. Defined in oo.fr. Methods described
-above.</dd>
-
-<dt>
-<b><tt>object</tt>&nbsp;</b></dt>
-
-<dd>
-Mother of all Ficl objects. Defines default initialization and array indexing
-methods. Defined in oo.fr. Methods described above.</dd>
-
-<dt>
-<b><tt>c-ref</tt>&nbsp;</b></dt>
-
-<dd>
-Holds the signature of another object. Aggregate one of these into a data
-structure or container class to get polymorphic behavior. Methods &amp;
-members:&nbsp;</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; ( inst class -- ref-inst ref-class )</tt></dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( ref-inst ref-class inst class -- )</tt></dd>
-
-<dd>
-<tt>.instance&nbsp;&nbsp; ( inst class -- a-addr ) </tt>cell member that
-holds the instance</dd>
-
-<dd>
-<tt>.class&nbsp;&nbsp; ( inst class -- a-addr ) </tt>cell member that holds
-the class</dd>
-
-<dt>
-<b><tt>c-byte&nbsp;</tt></b></dt>
-
-<dd>
-Primitive class derived from <tt>object</tt>, with a 1-byte payload. Set
-and get methods perform correct width fetch and store. Methods &amp; members:</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; ( inst class -- c )</tt></dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( c inst class -- )</tt></dd>
-
-<dd>
-<tt>.payload&nbsp;&nbsp; ( inst class -- addr ) </tt>member holds instance's
-value</dd>
-
-<dt>
-<b><tt>c-2byte</tt></b>&nbsp;</dt>
-
-<dd>
-Primitive class derived from <tt>object</tt>, with a 2-byte payload. Set
-and get methods perform correct width fetch and store. Methods &amp; members:</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; ( inst class -- 2byte )</tt></dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( 2byte inst class -- )</tt></dd>
-
-<dd>
-<tt>.payload&nbsp;&nbsp; ( inst class -- addr ) </tt>member holds instance's
-value</dd>
-
-<dt>
-<b><tt>c-4byte</tt></b>&nbsp;</dt>
-
-<dd>
-Primitive class derived from <tt>object</tt>, with a 4-byte payload. Set
-and get methods perform correct width fetch and store. Methods &amp; members:</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; ( inst class -- x )</tt></dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( x inst class -- )</tt></dd>
-
-<dd>
-<tt>.payload&nbsp;&nbsp; ( inst class -- addr ) </tt>member holds instance's
-value</dd>
-
-<dt>
-<b><tt>c-cell</tt></b>&nbsp;</dt>
-
-<dd>
-Primitive class derived from <tt>object</tt>, with a cell payload (equivalent
-to c-4byte in 32 bit implementations, 64 bits wide on Alpha). Set and get
-methods perform correct width fetch and store. Methods &amp; members:</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; ( inst class -- x )</tt></dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( x inst class -- )</tt></dd>
-
-<dd>
-<tt>.payload&nbsp;&nbsp; ( inst class -- addr ) </tt>member holds instance's
-value</dd>
-
-<dt>
-<b><tt>c-ptr</tt></b></dt>
-
-<dd>
-Base class derived from <tt>object</tt> for pointers to non-object types.
-This class is not complete by itself: several methods depend on a derived
-class definition of <tt>@size</tt>. Methods &amp; members:</dd>
-
-<dd>
-<tt>.addr&nbsp;&nbsp; ( inst class -- a-addr )</tt> member variable - holds
-the pointer address</dd>
-
-<dd>
-<tt>get-ptr&nbsp;&nbsp; ( inst class -- ptr )</tt></dd>
-
-<dd>
-<tt>set-ptr&nbsp;&nbsp; ( ptr inst class -- )</tt></dd>
-
-<dd>
-<tt>inc-ptr&nbsp;&nbsp; ( inst class -- )</tt> Adds @size to pointer address</dd>
-
-<dd>
-<tt>dec-ptr&nbsp;&nbsp; ( inst class -- )</tt> Subtracts @size from pointer
-address</dd>
-
-<dd>
-<tt>index-ptr&nbsp;&nbsp; ( i inst class -- )</tt> Adds i*@size to pointer
-address</dd>
-
-<dt>
-<b><tt>c-bytePtr</tt></b></dt>
-
-<dd>
-Pointer to byte derived from c-ptr. Methods &amp; members:</dd>
-
-<dd>
-<tt>@size&nbsp;&nbsp; ( inst class -- size )</tt> Push size of the pointed-to
-thing</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; (&nbsp; inst class -- c ) </tt>Fetch the pointer's
-referent byte</dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( c inst class -- ) </tt>Store c at the pointer address</dd>
-
-<dt>
-<b><tt>c-2bytePtr</tt></b></dt>
-
-<dd>
-Pointer to double byte derived from c-ptr. Methods &amp; members:</dd>
-
-<dd>
-<tt>@size&nbsp;&nbsp; ( inst class -- size )</tt> Push size of the pointed-to
-thing</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; (&nbsp; inst class -- x ) </tt>Fetch the pointer's
-referent 2byte</dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( x inst class -- )</tt> Store 2byte x at the pointer
-address</dd>
-
-<dt>
-<b><tt>c-4bytePtr</tt></b></dt>
-
-<dd>
-Pointer to quad-byte derived from c-ptr. Methods &amp; members:</dd>
-
-<dd>
-<tt>@size&nbsp;&nbsp; ( inst class -- size )</tt> Push size of the pointed-to
-thing</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; (&nbsp; inst class -- x ) </tt>Fetch the pointer's
-referent 2byte</dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( x inst class -- )</tt> Store 2byte x at the pointer
-address</dd>
-
-<dt>
-<b><tt>c-cellPtr</tt></b></dt>
-
-<dd>
-Pointer to cell derived from c-ptr. Methods &amp; members:</dd>
-
-<dd>
-<tt>@size&nbsp;&nbsp; ( inst class -- size )</tt> Push size of the pointed-to
-thing</dd>
-
-<dd>
-<tt>get&nbsp;&nbsp; (&nbsp; inst class -- x ) </tt>Fetch the pointer's
-referent cell</dd>
-
-<dd>
-<tt>set&nbsp;&nbsp; ( x inst class -- )</tt> Storex at the pointer address</dd>
-
-<dt>
-<b><tt>c-string</tt></b>&nbsp; (see string.fr)</dt>
-
-<dd>
-Dynamically allocated string similar to MFC CString (Partial list of methods
-follows)</dd>
-
-<dd>
-<font face="Courier New"><font size=-1>set ( c-addr u 2:this -- ) </font></font><font size=+0>Initialize
-buffer to the specified string</font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>get ( 2:this -- c-addr u ) Return
-buffer contents as counted string</font></font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>cat ( c-addr u 2:this -- ) Append
-given string to end of buffer</font></font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>compare ( 2string 2:this -- n ) Return
-result of lexical compare</font></font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>type ( 2:this -- ) Print buffer to
-the output stream</font></font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>hashcode ( 2:this -- x ) Return hashcode
-of string (as in dictionary)</font></font></dd>
-
-<dd>
-<font face="Courier New"><font size=-1>free ( 2:this -- ) Release internal
-buffer</font></font></dd>
-
-<dt>
-<b><tt>c-hashstring</tt>&nbsp; </b>(see string.fr)</dt>
-
-<dd>
-Derived from c-string. This class adds a hashcode member variable.</dd>
-</dl>
-</td>
-</tr>
-</table>
-
-</body>
-</html>
diff --git a/doc/ficl_parse.html b/doc/ficl_parse.html
deleted file mode 100644
index a90607778f0e..000000000000
--- a/doc/ficl_parse.html
+++ /dev/null
@@ -1,197 +0,0 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Author" content="john sadler">
- <meta name="Description" content="the coolest embedded scripting language ever">
- <title>Ficl Parse Steps</title>
-</head>
-<body>
-<link REL="SHORTCUT ICON" href="ficl.ico">
-<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" ><tr><td>
-<h1>Ficl Parse Steps</h1>
-<script language="javascript" src="ficlheader.js"></script>
-
-<h2>Overview</h2>
-<p>
-Ficl 2.05 and later includes an extensible parser chain. Ficl feeds every incoming token
-(chunk of text with no internal whitespace) to each step in the parse chain in turn. The
-first parse step that successfully matches the token applies semantics to it and returns
-a TRUE flag, ending the sequence. If all parse steps fire without a match, ficl prints
-an error message and resets the virtual machine. Parse steps can be written in precompiled
-code, or in ficl itself, and can be appended to the chain at run-time if you like.
-</p>
-<p>
-More detail:
-</p>
-<ul>
-<li>
-If compiling and local variable support is enabled, attempt to find the token in the local
-variable dictionary. If found, execute the token's compilation semantics and return
-</li>
-<li>
-Attempt to find the token in the system dictionary. If found, execute the token's semantics
-(may be different when compiling than when interpreting) and return
-</li>
-<li>
-If prefix support is enabled (Compile-time constant FICL_WANT_PREFIX in sysdep.h is non-zero),
-attempt to match the beginning of the token to the list of known prefixes. If there's a match,
-execute the associated prefix method.
-</li>
-<li>
-Attempt to convert the token to a number in the present <code>BASE</code>. If successful, push the
-value onto the stack if interpreting, compile it if compiling. Return
-</li>
-<li>
-All previous parse steps failed to recognize the token. Print "<token> not found" and abort
-</li>
-</ul>
-You can add steps to the parse chain, and you can add prefixes.
-<h2>Adding Parse Steps</h2>
-You can add a parse step in two ways. The first is to write a ficl word that
-has the correct stack signature for a parse step:
-<pre>
-my-parse-step ( c-addr u -- ??? flag )
-</pre>
-Where <code>c-addr u</code> are the address and length of the incoming token,
-and <code>flag</code> is <code>true</code> if the parse step recognizes the token
-and <code>false</code> otherwise.
-<br>
-Install the parse step using <code>add-parse-step</code>.
-A trivial example:
-<pre>
-: ?silly ( c-addr u -- flag )
- ." Oh no! Not another " type cr true ;
-' ?silly add-parse-step
-parse-order
-</pre>
-<p>
-The other way to add a parse step is by writing it in C, and inserting it into the
-parse chain with:
-</p>
-<pre>
-void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep);
-</pre>
-Where <code>name</code> is the display name of the parse step in the parse chain (as revealed
-by <code>parse-order</code>). Parameter pStep is a pointer to the code for the parse step itself,
-and must match the following declaration:
-<pre>
-typedef int (*FICL_PARSE_STEP)(FICL_VM *pVM, STRINGINFO si);
-</pre>
-<p>
-Upon entry to the parse step, <code>si</code> points to the incoming token. The parse step
-must return <code>FICL_TRUE</code> if it succeeds in matching the token, and
-<code>FICL_TRUE</code> otherwise. If it succeeds in matching a token, the parse step
-applies semantics to it before returning. See <code>ficlParseNumber()</code> in words.c for
-an example.
-</p>
-
-<h2>Adding Prefixes</h2>
-<p>
-What's a prefix, anyway? A prefix (contributed by Larry Hastings) is a token that's
-recognized as the beginning of another token. Its presence modifies the semantics of
-the rest of the token. An example is <code>0x</code>, which causes digits following
-it to be converted to hex regardless of the current value of <code>BASE</code>.
-</p><p>
-Caveat: Prefixes are matched in sequence, so the more of them there are,
-the slower the interpreter gets. On the other hand, because the prefix parse step occurs
-immediately after the dictionary lookup step, if you have a prefix for a particular purpose,
-using it may save time since it stops the parse process.
-</p><p>
-Each prefix is a ficl word stored in a special wordlist called <code>&lt;prefixes&gt;</code>. When the
-prefix parse step (<code>?prefix</code> AKA ficlParsePrefix()) fires, it searches each word
-in <code>&lt;prefixes&gt;</code> in turn, comparing it with the initial characters of the incoming
-token. If a prefix matches, the parse step returns the remainder of the token to the input stream
-and executes the code associated with the prefix. This code can be anything you like, but it would
-typically do something with the remainder of the token. If the prefix code does not consume the
-rest of the token, it will go through the parse process again (which may be what you want).
-</p><p>
-Prefixes are defined in prefix.c and in softwords/prefix.fr. The easiest way to add a new prefix is
-to insert it into prefix.fr and rebuild the system. You can also add prefixes interactively
-by bracketing prefix definitions as follows (see prefix,fr):
-</p>
-<pre>
-start-prefixes ( defined in prefix.fr )
-\ make dot-paren a prefix (create an alias for it in the prefixes list)
-: .( .( ;
-: 0b 2 __tempbase ; immediate
-end-prefixes
-</pre>
-<p>
-The precompiled word <code>__tempbase</code> is a helper for prefixes that specify a
-temporary value of <code>BASE</code>.
-</p><p>
-Constant <code>FICL_EXTENDED_PREFIX</code> controls the inclusion of a bunch of additional
-prefix definitions. This is turned off in the default build since several of these prefixes
-alter standard behavior, but you might like them.
-</p>
-
-<h2>Notes</h2>
-<p>
-Prefixes and parser extensions are non-standard, although with the exception of prefix support,
-ficl's default parse order follows the standard. Inserting parse steps in some other order
-will almost certainly break standard behavior.
-</p>
-<p>
-The number of parse steps that can be added to the system is limited by the value of
-<code>FICL_MAX_PARSE_STEPS</code> (defined in sysdep.h unless you define it first), which defaults
-to 8. More parse steps means slower average interpret and compile performance,
-so be sparing. Same applies to the number of prefixes defined for the system, since each one
-has to be matched in turn before it can be proven that no prefix matches. On the other hand,
-if prefixes are defined, use them when possible: since they are matched early in the parse order,
-a prefix match short circuits the parse process, saving time relative to
-(for example) using a number builder parse step at the end of the parse chain.
-</p>
-<p>
-Compile time constant <code>FICL_EXTENDED_PREFIX</code> enables several more prefix
-definitions in prefix.c and prefix.fr. Please note that this will slow average compile and
-interpret speed in most cases.
-</p>
-<h2>Parser Glossary</h2>
-<dl>
-<dt><b><code>parse-order ( -- )</code></b></dt>
-<dd>
-Prints the list of parse steps in the order in which they are evaluated.
-Each step is the name of a ficl word with the following signature:
-<pre>
-parse-step ( c-addr u -- ??? flag )
-</pre>
-A parse step consumes a counted string (the incoming token) from the stack,
-and exits leaving a flag on top of the stack (it may also leave other parameters as side effects).
-The flag is true if the parse step succeeded at recognizing the token, false otherwise.
-</dd>
-<dt><b><code>add-parse-step ( xt -- )</code></b></dt>
-<dd>
-Appends a parse step to the parse chain. XT is the adress (execution token) of a ficl
-word to use as the parse step. The word must have the following signature:
-<pre>
-parse-step ( c-addr u -- ??? flag )
-</pre>
-A parse step consumes a counted string (the incoming token) from the stack,
-and exits leaving a flag on top of the stack (it may also leave other parameters as side effects).
-The flag is true if the parse step succeeded at recognizing the token, false otherwise.
-</dd>
-<dt><b><code>show-prefixes ( -- )</code></b></dt>
-<dd>
-Defined in <code>softwords/prefix.fr</code>.
-Prints the list of all prefixes. Each prefix is a ficl word that is executed if its name
-is found at the beginning of a token. See <code>softwords/prefix.fr</code> and <code>prefix.c</code> for examples.
-</dd>
-<dt><b><code>start-prefixes ( -- )</code></b></dt>
-<dd>
-Defined in <code>softwords/prefix.fr</code>.
-Declares the beginning of one or more prefix definitions (it just switches the compile wordlist
-to <code>&lt;prefixes&gt;</code>
-</dd>
-<dt><b><code>end-prefixes ( -- )</code></b></dt>
-<dd>
-Defined in <code>softwords/prefix.fr</code>.
-Restores the compilation wordlist that was in effect before the last invocation of
-<code>start-prefixes</code>. Note: the prior wordlist ID is stored in a Ficl variable, so
-attempts to nest <code>start-prefixes end-prefixes</code> blocks wil result in mildly silly
-side effects.
-</dd>
-</dl>
-</td></tr></table>
-</body>
-</html> \ No newline at end of file
diff --git a/doc/ficlheader.js b/doc/ficlheader.js
deleted file mode 100644
index 56ff63529e2b..000000000000
--- a/doc/ficlheader.js
+++ /dev/null
@@ -1,19 +0,0 @@
-function ficlHeader()
-{
- document.write("<table BORDER=0 CELLSPACING=3 WIDTH='640' %>");
- document.write("<tr %>");
- document.write("<td %> <b %>Forth Inspired Command Language</b %></td %>");
- document.write("<td ROWSPAN='4' %><a href='http://ficl.sourceforge.net' %><img SRC='ficl_logo.jpg' border='0' alt='The ficl home page' height=64 width=64 %></a %></td %>");
- document.write("<td ROWSPAN='4' %><A href='http://sourceforge.net' %><IMG src='http://sourceforge.net/sflogo.php?group_id=24441' width='88' height='31' border='0' alt='Sourceforge Logo' %></A %></td %>");
- document.write("<td ROWSPAN='4' %><a href='http://www.links2go.net/topic/Forth' %><img SRC='skey.gif' ALT='Key Resources -- Forth' BORDER=0 height=81 width=81 %></a %></td %>");
- document.write("</tr %>");
- document.write("<tr %><td %><b %>Author: <a href='mailto:john_sadler@alum.mit.edu' %> John Sadler</a %></b %></td %></tr %>");
- document.write("<tr %><td %><b %>Created: 19 July 1997</b %></td %></tr %>");
- document.write("<tr %><td %><b %>Current Revision: 3.00a -- July 2001</b %></td %></tr %>");
- document.write("<tr %><td %><b %>Last Modified " + document.lastModified + "</b %></td %></tr %>");
- document.write("<tr %><td COLSPAN=4 %><b %><a href='index.html' %>Home</a %>&nbsp;|&nbsp;<a href='http://sourceforge.net/mail/?group_id=24441' %>Join Mailing Lists</a %>&nbsp;|&nbsp;<a href='http://sourceforge.net/projects/ficl' %>Project Page</a %>&nbsp|&nbsp;<a href='http://sourceforge.net/project/showfiles.php?group_id=24441' %>Download</a %></b %></td %></tr %>");
- document.write("</table %>");
-}
-
-ficlHeader();
-
diff --git a/doc/graphics/4ring.gif b/doc/graphics/4ring.gif
new file mode 100644
index 000000000000..b3ca2f61a087
--- /dev/null
+++ b/doc/graphics/4ring.gif
Binary files differ
diff --git a/doc/graphics/ficl.4.128.jpg b/doc/graphics/ficl.4.128.jpg
new file mode 100644
index 000000000000..0bebbb5ad3db
--- /dev/null
+++ b/doc/graphics/ficl.4.128.jpg
Binary files differ
diff --git a/doc/graphics/ficl.4.64.jpg b/doc/graphics/ficl.4.64.jpg
new file mode 100644
index 000000000000..7cca654ad50b
--- /dev/null
+++ b/doc/graphics/ficl.4.64.jpg
Binary files differ
diff --git a/doc/graphics/ficl.4.96.jpg b/doc/graphics/ficl.4.96.jpg
new file mode 100644
index 000000000000..67fb5f38cd77
--- /dev/null
+++ b/doc/graphics/ficl.4.96.jpg
Binary files differ
diff --git a/doc/ficl_oop.jpg b/doc/graphics/ficl_oop.jpg
index b4aee1021a98..b4aee1021a98 100644
--- a/doc/ficl_oop.jpg
+++ b/doc/graphics/ficl_oop.jpg
Binary files differ
diff --git a/doc/ficl_top.jpg b/doc/graphics/ficl_top.jpg
index f206d7131b91..f206d7131b91 100644
--- a/doc/ficl_top.jpg
+++ b/doc/graphics/ficl_top.jpg
Binary files differ
diff --git a/doc/graphics/sourceforge.jpg b/doc/graphics/sourceforge.jpg
new file mode 100644
index 000000000000..befbd3c1b946
--- /dev/null
+++ b/doc/graphics/sourceforge.jpg
Binary files differ
diff --git a/doc/index.html b/doc/index.html
index 850acfd0cd13..3f811e3b5497 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -1,116 +1,382 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
- <HEAD>
- <META name="Author" content="john sadler">
- <META name="Description" content="Ficl - embedded scripting with object oriented programming">
- <META name="Keywords" content="scripting prototyping tcl OOP Forth interpreter C">
-<STYLE>
- H1 {font: Arial; color: navy}
- H2 {font: Arial; color: navy}
- LI {font: Arial}
-</STYLE>
- <LINK rel="SHORTCUT ICON" href="ficl.ico">
- <TITLE>
- Ficl - Embedded Scripting - Index
- </TITLE>
- </HEAD>
- <BODY>
- <H1>
- <B>Ficl Documentation</B>
- </H1>
-<SCRIPT language="javascript" src="ficlheader.js" type="text/javascript">
-</SCRIPT>
- <TABLE summary="table of contents" border="0" cellspacing="3" cols="2" width="675">
- <TR>
- <TD width="500">
- <H2>
- Contents
- </H2>
- <UL>
- <LI>
- <A href="ficl_rel.html">Release notes</A>
- </LI>
- <LI>
- <A href="ficl.html#whatis">What is ficl?</A>
- </LI>
- <LI>
- <A href="http://sourceforge.net/projects/ficl">Ficl project page on Sourceforge</A>
- </LI>
- <LI>
- <A href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download</A>
- </LI>
- <LI>
- <A href="ficl.html#links">Tutorials and References</A>
- </LI>
- <LI>
- <A href="ficl.html#includesficl">Ficl Inside!</A>
- </LI>
- <LI>
- <A href="ficl.html#lawyerbait">Disclaimer &mp; License</A>
- </LI>
- <LI>
- <A href="ficl.html#features">Ficl features</A>
- </LI>
- <LI>
- <A href="ficl.html#porting">Porting</A>
- </LI>
- <LI>
- <A href="ficl.html#api">Application Programming Interface</A>
- </LI>
- <LI>
- <A href="ficl.html#manifest">Distribution source files</A>
- </LI>
- <LI>
- <A href="ficl_loc.html">Local variables</A>
- </LI>
- <LI>
- <A href="ficl_oop.html">Object Oriented Programming in ficl</A>
- </LI>
- <LI>
- <A href="ficl_debug.html">Ficl Debugger</A>
- </LI>
- <LI>
- <A href="ficl.html#extras">Ficl extras</A>
- <UL>
- <LI>
- <A href="ficl.html#exnumber">Number syntax</A>
- </LI>
- <LI>
- <A href="ficl_parse.html">Parser extensions and prefix support</A>
- </LI>
- <LI>
- <A href="ficl.html#exsearch">Search order words</A>
- </LI>
- <LI>
- <A href="ficl.html#exuser">User variables</A>
- </LI>
- <LI>
- <A href="ficl.html#exmisc">Miscellaneous useful words</A>
- </LI>
- <LI>
- <A href="ficl.html#exficlwin">FiclWin words</A>
- </LI>
- </UL>
- </LI>
- <LI>
- <A href="ficl.html#ansinfo">ANS required information</A>
- </LI>
- </UL>
- </TD>
- <TD width="175">
- <A href="http://nav.webring.yahoo.com/hub?ring=forth&mp;list"><IMG src="http://www.iidbs.com/images/4ring.gif" width="155" height="140" border="0" alt="Forth Webring Logo"></A>
- <CENTER>
- <FONT size="3"><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;id=47;prev5">Previous 5 Sites</A><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;id=47;prev">Previous</A><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;id=47;next">Next</A><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;id=47;next5">Next 5 Sites</A><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;random">Random Site</A><BR>
- <A href="http://www.webring.org/cgi-bin/webring?ring=forth;list">List Sites</A></FONT>
- </CENTER>
- </TD>
- </TR>
- </TABLE>
- </BODY>
-</HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='WhatisFicl'>
+What is Ficl?
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+Ficl is a programming language interpreter designed to be embedded
+into other systems as a command, macro, and development prototyping
+language.
+<p>
+
+Ficl is an acronym for "Forth Inspired Command Language".
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclFeatures'>
+Ficl Features
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+
+<p><dt>
+Ficl is <b><i>easy to port.</i></b>
+<dd>
+
+
+
+<ul>
+
+<li>
+It typically takes under 2 hours to port to a new platform.
+
+<li>
+Ficl is written in strict ANSI C.
+
+<li>
+Ficl can run natively on 32- and 64-bit processors.
+
+</ul>
+
+
+
+<p><dt>
+Ficl has a <b><i>small memory footprint.</i></b>
+<dd>
+
+
+
+A fully featured Win32 console version takes less than 100K
+of memory, and a minimal version is less
+than half that.
+
+
+
+<p><dt>
+Ficl is <b><i>easy to integrate</i></b> into your program.
+<dd>
+
+
+
+Where most Forths view themselves as the center of the system and
+expect the rest of the system to be coded in Forth, Ficl acts as a
+component of your program. It is easy to export code written in C or
+ASM to Ficl (in the style of TCL), or to invoke Ficl code from a
+compiled module.
+
+
+
+<p><dt>
+Ficl is <b><i>fast.</i></b>
+<dd>
+
+
+
+Thanks to its
+<a href=http://www.complang.tuwien.ac.at/forth/threaded-code.html#switch-threading>"switch-threaded"</a>
+virtual machine design, Ficl 4 is faster than ever&mdash;about 3x the speed of Ficl 3.
+Ficl also features blindingly fast "just in time" compiling, removing the "compile" step from
+the usual compile-debug-edit iterative debugging cycle.
+
+
+
+<p><dt>
+Ficl is a <b><i>complete and powerful programming language.</i></b>
+<dd>
+
+
+
+Ficl is an implementation of the FORTH language, a language providing
+a wide range of standard programming language features:
+<ul>
+
+<li>
+Integer and floating-point numbers, with a rich set of operators.
+
+<li>
+Arrays.
+
+<li>
+File I/O.
+
+<li>
+Flow control (<code>if/then/else</code> and many looping structures).
+
+<li>
+Subroutines with named arguments.
+
+<li>
+Language extensibility.
+
+<li>
+Powerful code pre-processing features.
+
+</ul>
+
+
+
+<p><dt>
+Ficl is <b><i>standards-compliant.</i></b>
+<dd>
+
+
+
+Ficl conforms to the 1994 ANSI Standard for FORTH (DPANS94).
+See <a href=dpans.html>ANS Required Information</a> for
+more detail.
+
+
+<p><dt>
+Ficl is <b><i>extensible.</i></b>
+<dd>
+
+
+
+Ficl is extensible both at compile-time and at run-time.
+You can add new script functions, new native functions,
+even new control structures.
+
+
+
+
+<p><dt>
+Ficl adds <b><i>object oriented programming features.</i></b>
+<dd>
+
+
+
+Ficl's flexible OOP library can be used to wrap
+data structures or classes of the host system without altering them.
+(And remember how we said Ficl was extensible? Ficl's object-oriented
+programming extensions are written in Ficl.)
+
+
+
+<p><dt>
+Ficl is <b><i>interactive.</i></b>
+<dd>
+
+
+
+Ficl can be used interactively, like most other FORTHs, Python,
+and Smalltalk. You can inspect data, run commands, or even
+define new commands, all on a running Ficl VM.
+Ficl also has a built-in script debugger that allows you to
+step through Ficl code as it is executed.
+
+
+<p><dt>
+Ficl is <b><i>ROMable.</i></b>
+<dd>
+
+
+
+Ficl is designed to work in RAM based and ROM code / RAM
+data environments.
+
+
+
+<p><dt>
+Ficl is <b><i>safe for multithreaded programs.</i></b>
+<dd>
+
+
+
+Ficl is reentrant and thread-safe. After initialization,
+it does not write to any global data.
+
+
+<p><dt>
+Ficl is <b><i>open-source and free.</i></b>
+<dd>
+
+
+
+The <a href=license.html>Ficl licence</a> is a BSD-style
+license, requiring only that you document that you are
+using Ficl. There are no licensing costs for using Ficl.
+
+
+</dl>
+
+
+<a name=whatsnew>
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='WhatsNewInFicl40'>
+What's New In Ficl 4.0?
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+</a>
+
+Ficl 4.0 is a major change for Ficl. Ficl 4.0 is <i>smaller</i>,
+<i>faster</i>, <i>more powerful</i>, and <i>easier to use</i>
+than ever before. (Or your money back!)
+<p>
+
+Ficl 4.0 features a major engine rewrite. Previous versions
+of Ficl stored compiled words as an array of pointers to data
+structure; Ficl 4.0 adds "instructions", and changes over to
+mostly using a "switch-threaded" model. The result? Ficl 4.0
+is approximately <i>three times</i> as fast as Ficl 3.03.
+<p>
+
+Ficl 4.0 also adds the ability to store the "softcore" words
+as LZ77 compressed text. Decompression is so quick as to be
+nearly unmeasurable (0.00384 seconds on a 750MHz AMD Duron-based
+machine). And even with the runtime decompressor, the resulting
+Ficl executable is over 13k smaller!
+<p>
+
+Another new feature: Ficl 4.0 can take advantage of native
+support for double-word math. If your platform supports it,
+set the preprocessor symbol <code>FICL_HAVE_NATIVE_2INTEGER</code>
+to 1, and create <code>typedefs</code> for <code>ficl2Integer</code>
+and <code>ficl2Unsigned</code>.
+<p>
+
+Ficl 4.0 also features a retooled API, and a redesigned directory
+tree. The API is now far more consistent. But for those of you
+who are upgrading from Ficl 3.03 or before, you can enable API
+backwards compatibility by turning on the compile-time flag
+<code>FICL_WANT_COMPATIBILITY</code>.
+<p>
+
+Ficl 4.0 also extends support every kind of local and
+global value imaginable. Every values can individually
+be local or global, single-cell or double-cell, and
+integer or floating-point.
+And <code>TO</code> <i>always</i> does the right thing.
+<p>
+
+If you're using Ficl under Windows, you'll be happy
+to know that there's a brand-new build process.
+The Ficl build process now builds Ficl as
+<ul>
+
+<li>
+a static library (.LIB),
+
+<li>
+a dynamic library (.DLL, with a .LIB import library), and
+
+<li>
+a standalone executable (.EXE).
+
+</ul>
+
+Furthermore, each of these targets can be built in
+Debug or Release, Singlethreaded or Multithreaded,
+and optionally using the DLL version of the C runtime
+library for Multithreaded builds. (And, plus, the
+<code>/objects/common</code> nonsense is gone!)
+<p>
+
+
+Finally, Ficl 4.0 adds a <code>contrib</code>
+directory, a repository for user-contributed code that isn't
+part of the standard Ficl release. The only package there
+right now is <b>XClasses</b>, a Python-based IDL that generates
+the definition files for C++-based classes, the equivalent Ficl
+classes, and code to allow the Ficl classes to call the C++ methods.
+Using <b>XClasses</b> you can write your class once, and use it
+immediately from both C++ and Ficl.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='GettingFicl'>
+Getting Ficl
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+You can download Ficl from the
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441>
+Ficl download page at Sourceforge</a>.
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
diff --git a/doc/license.html b/doc/license.html
new file mode 100644
index 000000000000..324b134a1941
--- /dev/null
+++ b/doc/license.html
@@ -0,0 +1,103 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl licensing</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl licensing
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclLicenseAndDisclaimer'>
+Ficl License And Disclaimer
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<font size=+1>
+Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+<br>
+All rights reserved.
+</font>
+<p>
+
+<b>
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+<ol>
+
+<li>
+Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+<li>
+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.
+
+</ol>
+
+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.
+</b>
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/links.html b/doc/links.html
new file mode 100644
index 000000000000..5073ef5d3266
--- /dev/null
+++ b/doc/links.html
@@ -0,0 +1,318 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl links</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl links
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='OfficialFiclPages'>
+Official Ficl Pages
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<p><dt>
+<a href="http://ficl.sourceforge.net">http://ficl.sourceforge.net</a>
+<dd>
+
+
+The official web home of Ficl.
+
+<p><dt>
+<a href="http://sourceforge.net/project/showfiles.php?group_id=24441">http://sourceforge.net/project/showfiles.php?group_id=24441</a>
+<dd>
+
+
+The Ficl download page.
+
+
+</dl>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='ForthPrimersAndTutorials'>
+Forth Primers And Tutorials
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<p><dt>
+<a href="http://www.phys.virginia.edu/classes/551.jvn.fall01/primer.htm">http://www.phys.virginia.edu/classes/551.jvn.fall01/primer.htm</a>
+<dd>
+
+
+An excellent Forth primer, by Julian Nobel.
+
+<p><dt>
+<a href="http://ficl.sourceforge.net/pdf/Forth_Primer.pdf">http://ficl.sourceforge.net/pdf/Forth_Primer.pdf</a>
+<dd>
+
+
+Another excellent Forth primer, by Hans Bezemer.
+
+<p><dt>
+<a href="http://www.taygeta.com/forth_intro/stackflo.html">http://www.taygeta.com/forth_intro/stackflo.html</a>
+<dd>
+
+
+<i>An Introduction To Forth Using Stack Flow</i> by Gordon Charton.
+Mr. Charton's stack-flow diagrams make it easy to understand how
+to manipulate the FORTH stacks.
+
+<p><dt>
+<a href="http://www.softsynth.com/pforth/pf_tut.htm">http://www.softsynth.com/pforth/pf_tut.htm</a>
+<dd>
+
+
+Phil Burk's Forth Tutorial.
+
+</dl>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='TechnicalArticlesOnFiclAndForth'>
+Technical Articles On Ficl And Forth
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<p><dt>
+<a href="articles/ficlddj.pdf">articles/ficlddj.pdf</a>
+<dd>
+
+
+Manuscript of John Sadler's article on Ficl for January 1999 <a href=http://www.ddj.com>Dr. Dobb's Journal</a>.
+
+<p><dt>
+<a href="articles/jwsforml.pdf">articles/jwsforml.pdf</a>
+<dd>
+
+
+1998 FORML Conference paper: <i>OO Programming in Ficl,</i> written and presented by John Sadler.
+
+
+<p><dt>
+<a href="http://www.complang.tuwien.ac.at/forth/threaded-code.html">http://www.complang.tuwien.ac.at/forth/threaded-code.html</a>
+<dd>
+
+
+Anton Ertl's description of threaded code techniques. (The FORTH-related definition
+of "threaded code" is different from&mdash;and predates&mdash;the common modern
+usage dealing with light-weight processes.) Ficl 4 uses what Ertl calls
+"switch threading".
+
+<p><dt>
+<a href="http://ficl.sourceforge.net/dpans/dpans.htm">http://ficl.sourceforge.net/dpans/dpans.htm</a>
+<dd>
+
+
+1994 Draft Proposed American National Standard for Forth.
+And surprisingly readable, as language standards go.
+
+<p><dt>
+<a href="http://www.taygeta.com/forthlit.html">http://www.taygeta.com/forthlit.html</a>
+<dd>
+
+
+Forth literature index on Taygeta, a web clearinghouse of Forth links.
+
+</dl>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='OtherForthSitesOfInterest'>
+Other Forth Sites Of Interest
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<p><dt>
+<a href="http://www.forth.org">http://www.forth.org</a>
+<dd>
+
+
+The Forth Interest Group.
+
+<p><dt>
+<a href="http://www.forth.com">http://www.forth.com</a>
+<dd>
+
+
+FORTH, Incorporated. Thirty years old and going strong.
+You might be surprised to learn that they wrote software for
+the <a href=http://www.forth.com/Content/Stories/FedEx.htm>FedEx</a>
+"SuperTracker" bar code scanners / package trackers.
+
+</dl>
+
+<table width=100% bgcolor=#e0e0e0><tr><td width=160>
+<A href="http://t.webring.com/hub?sid=&ring=forth&list"><IMG src="graphics/4ring.gif" width="155" height="140" border="0" alt="Forth Webring Logo"></A>
+</td><td>
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='TheForthWebRing'>
+The Forth Web Ring
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&prev5">Previous 5 Sites</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&prev">Previous</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&next">Next</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&next5">Next 5 Sites</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&random">Random Site</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&list">List Sites</A></FONT>
+</td></tr></table>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='SomeSoftwareThatUsesFicl'>
+Some Software That Uses Ficl
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+<li>
+The <a href="http://www.freebsd.org/">FreeBSD</a> boot loader
+(Daniel Sobral, Jordan Hubbard)
+
+<li>
+<a href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">
+SwitchCore
+</a>
+Gigabit Ethernet switches (&Ouml;rjan Gustavsson )
+
+<li>
+<a href="http://debuffer.sourceforge.net/">
+Palm Pilot Debuffer
+</a>
+(Eric Sessoms)
+Also see <a href=http://sonic-weasel.org/eric/ficlx/>FiclX</a>, a C++ interface to Ficl.
+
+<li>
+<a href="http://www.swcp.com/%7Ejchavez/osmond.html">
+Osmond PC Board Layout tool
+</a>
+
+<li>
+<a href="http://www.netcomsystems.com">
+NetCom Systems
+</a>
+ML7710
+
+<li>
+<a href="http://www.parview.com/ds/homepage.html">
+ParView
+</a>
+GPS system
+
+<li>
+<a href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">
+PowerPlant Software
+</a>
+Development Environment for Linux
+
+<li>
+<a href="http://www.vyyo.com/products/architecture_v3000.html">
+Vyyo V3000 Broadband Wireless Hub
+</a>
+
+</ul>
+
+(Contact us if you'd like your name and product listed here.)
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/locals.html b/doc/locals.html
new file mode 100644
index 000000000000..c6c78d0206c6
--- /dev/null
+++ b/doc/locals.html
@@ -0,0 +1,253 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>local variables in Ficl</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+local variables in Ficl
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='AnOverviewAndAHistory'>
+An Overview And A History
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+
+Named, locally scoped variables came late to Forth. Purists feel that experienced
+Forth programmers can (and should) write supportable code using only anonymous
+stack variables and good factoring, and they complain that novices use
+global variables too frequently. But local variables cost little in terms of
+code size and execution speed, and are very convenient for OO programming
+(where stack effects are more complex).
+<p>
+
+Ficl provides excellent support
+for local variables, and the purists be damned&mdash;we use 'em all the time.
+<p>
+
+Local variables can only be declared inside a definition,
+and are only visible in that definition. Please refer to
+<a href="http://ficl.sourceforge.net/dpans/dpans13.htm">
+the ANS standard for FORTH
+</a> for more general information on local variables.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='John-HopkinsForthArgumentSyntax'>
+John-Hopkins Forth Argument Syntax
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+ANS Forth does not specify a complete local variable facility.
+Instead, it defines a foundation upon which to build one. Ficl comes with
+an adaptation of the Johns-Hopkins local variable syntax, as developed by John
+Hayes et al. However, Ficl extends this syntax with support for double-cell and
+floating-point numbers.
+
+<p>
+
+Here's the basic syntax of a JH-local variable declaration:
+<blockquote><code>
+<b>{</b> <i>arguments</i>
+<b>|</b> <i>locals</i>
+<b>--</b> <i>ignored</i>
+<b>}</b>
+</code></blockquote>
+(For experienced FORTH programmers: the declaration is designed to look like a stack comment,
+but it uses curly braces instead of parentheses.) Each section must list zero or more
+legal Ficl word names; comments and preprocessing are not allowed here.
+Here's what each section denotes:
+
+<ul>
+
+<li>
+The <i>arguments</i> section lists local variables which are initialized from the stack when the word executes.
+Each argument is set to the top value of the stack, starting at the rightmost argument name and moving left.
+You can have zero or more arguments.
+<p>
+
+<li>
+The <i>locals</i> section lists local variables which are set to zero when the word executes.
+You can have zero or more locals.
+<p>
+
+<li>
+Any characters between <code>--</code> and <code>}</code> are treated as a comment, and ignored.
+
+</ul>
+
+(The <code>|</code> and <code>--</code> sections are optional,
+but they must appear in the order shown if they appear at all.)
+<p>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='ArgumentTypes'>
+Argument Types
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Every time you specify a local variable (in either the <i>arguments</i> or the <i>locals</i> section),
+you can also specify the <i>type</i> of the local variable. By default, a local variable
+is a single-cell integer; you can specify that the local be a double-cell integer, and/or a
+floating-point number.
+<p>
+
+To specify the type of a local, specify one or more of the following single-character specifiers,
+followed by a colon (<code>:</code>).
+
+<table>
+
+<tr><td bgcolor=#e0e0e0>
+<b>1</b>
+</td><td bgcolor=#f0f0f0>
+single-cell
+</td></tr>
+
+
+
+<tr><td bgcolor=#e0e0e0>
+<b>2</b>
+</td><td bgcolor=#f0f0f0>
+double-cell
+</td></tr>
+
+
+
+<tr><td bgcolor=#e0e0e0>
+<b>d</b>
+</td><td bgcolor=#f0f0f0>
+double-cell
+</td></tr>
+
+
+
+<tr><td bgcolor=#e0e0e0>
+<b>f</b>
+</td><td bgcolor=#f0f0f0>
+floating-point (use floating stack)
+</td></tr>
+
+
+
+<tr><td bgcolor=#e0e0e0>
+<b>i</b>
+</td><td bgcolor=#f0f0f0>
+integer (use data stack)
+</td></tr>
+
+
+
+<tr><td bgcolor=#e0e0e0>
+<b>s</b>
+</td><td bgcolor=#f0f0f0>
+single-cell
+</td></tr>
+
+
+
+</table>
+
+For instance, the argument <code>f2:foo</code> would specify a double-width floating-point
+number.
+<p>
+
+The type specifiers are read right-to left, and when two specifiers conflict, the rightmost
+one takes priority. So <code>2is1f2:foo</code> would still specifiy a double-width floating-point
+number.
+<p>
+
+Note that this syntax <i>only works</i> for Ficl's JH-locals. Locals
+defined in some other way (say, with the FORTH standard word <code>LOCALS|</code>)
+will ignore this syntax, and the entire string will be used as the name of
+the local (type and all).
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='ASimpleExample'>
+A Simple Example
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<pre>
+: DEMONSTRATE-JH-LOCALS { c b a f:float -- a+b f:float*2 }
+ a b +
+ 2.0e float f*
+ ;
+</pre>
+
+
+</blockquote><p></td></tr></table></body></html>
+
diff --git a/doc/oop.html b/doc/oop.html
new file mode 100644
index 000000000000..ef0f7bfbdf9b
--- /dev/null
+++ b/doc/oop.html
@@ -0,0 +1,1640 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl oop</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl oop
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclObjectOrientedProgramming'>
+Ficl Object Oriented Programming
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+
+Ficl's object extensions provide the traditional OO benefits of associating
+data with the code that manipulates it, and reuse through single inheritance.
+Ficl also has some unusual capabilities that support interoperation with
+systems written in C.
+<p>
+
+Some design points of Ficl's OOP system:
+
+<ul>
+
+<li>
+Ficl objects are normally late bound for safety (late binding guarantees
+that the appropriate method will always be invoked for a particular object).
+Early binding is also available, provided you know the object's class at
+compile-time.
+
+<li>
+Ficl OOP supports single inheritance, aggregation, and arrays of objects.
+
+<li>
+Classes have independent name spaces for their methods: methods are only
+visible in the context of a class or object. Methods can be overridden
+or added in subclasses; there is no fixed limit on the number of methods
+of a class or subclass.
+
+<li>
+Ficl OOP syntax is regular and unified over classes and objects. In ficl,
+all classes are objects. Class methods include the ability to subclass
+and instantiate.
+
+<li>
+Ficl can adapt legacy data structures with object wrappers. You can model
+a structure in a Ficl class, and create an instance that refers to an address
+in memory that holds an instance of the structure. The <i>ref object</i>
+can then manipulate the structure directly. This lets you wrap data structures
+written and instantiated in C.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='Object-OrientedProgrammingconcepts'>
+Object-Oriented Programming concepts
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+If you're not familiar with object-oriented programming, you
+can click <a href="http://whatis.techtarget.com/definition/0,289893,sid9_gci212681,00.html">here</a>
+or <a href="http://www.softwaredesign.com/objects.html">here</a> for
+a general-purpose overview.
+Or click <a href="articles/oo_in_c.html#review">here</a> for a short review of object-oriented ideas,
+terms, and implementations in C.
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='Acknowledgements'>
+Acknowledgements
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Ficl is not the first Forth to include Object Oriented extensions. Ficl's
+OO syntax owes a debt to the work of John Hayes and Dick Pountain, among
+others. OO Ficl is different from other OO Forths in a few ways, though
+(some things never change). First, unlike several implementations, the
+syntax is documented (<a href="#ootutorial">below</a>) beyond the source
+code. In Ficl's spirit of working with C code, the OO syntax provides means
+to adapt existing data structures. I've tried to make Ficl's OO model simple
+and safe by unifying classes and objects, providing late binding by default,
+and separating namespaces so that methods and regular Forth words are not
+easily confused.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='FiclObjectModel'>
+Ficl Object Model
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+All classes in Ficl are derived from the common base class
+<code><a href="#objectgloss">OBJECT</a></code>
+as shown in the <a href="#figure1">figure</a> below. All classes are instances
+of <code><a href="#glossclass">METACLASS</a></code>. This means that classes
+are objects, too. <code>METACLASS</code> implements the methods for messages
+sent to classes. Class methods create instances and subclasses, and give
+information about the class. Each class is represented by a data stucture
+of three elements:
+
+<ol>
+
+<li>
+The address (named <code>.CLASS</code> ) of a parent class, or zero if it's
+a base class (only <code>OBJECT</code> and <code>METACLASS</code> have this property).
+
+<li>
+The size (named <code>.SIZE</code> ) in address units of an instance of the
+class.
+
+<li>
+A wordlist ID (named <code>.WID</code> ) for the methods of the class.
+
+</ol>
+
+In the figure below, <code>METACLASS</code> and <code>OBJECT</code> are real system-supplied
+classes. The others are contrived to illustrate the relationships among
+derived classes, instances, and the two system base classes. The dashed
+line with an arrow at the end indicates that the object/class at the arrow
+end is an instance of the class at the other end. The vertical line with
+a triangle denotes inheritance.
+<p>
+
+Note for the curious: <code>METACLASS</code> behaves like a class&mdash;it responds
+to class messages and has the same properties as any other class. If you
+want to twist your brain in knots, you can think of <code>METACLASS</code>
+as an instance of itself.
+<p>
+
+
+<a NAME="figure1"></a><img SRC="graphics/ficl_oop.jpg" VSPACE=10 height=442 width=652>
+<br>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='FiclObject-OrientedSyntaxTutorial'>
+Ficl Object-Oriented Syntax Tutorial
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a NAME="ootutorial"></a>
+
+It's helpful to have some familiarity with Forth and the customary Forth
+stack notation to understand this tutorial. To get started, take a look
+at this <a href="http://www.taygeta.com/forth_intro/stackflo.html">web-based
+Forth tutorial</a>. If you're comfortable with both OO and Forth, you can
+<a href="#ootutorial-finally">jump ahead</a>.
+<p>
+
+A Ficl <a href="oo_in_c.html#object-def">object</a> associates a <a href="oo_in_c.html#class-def">class</a>
+with an <a href="oo_in_c.html#instance-def">instance</a> (the storage for
+one set of instance variables). This is done explicitly on Ficl's stack,
+in that any Ficl object is represented by a cell pair:
+<blockquote><code>( INSTANCE-address CLASS-address )</code></blockquote>
+
+The <code>INSTANCE-address</code> is the address of the object's storage, and the <code>CLASS-address</code>
+is the address of its class. Whenever a named Ficl object executes (e.g.
+when you type its name and press enter at the Ficl prompt), it leaves this
+"signature". All methods by convention expect a class and instance on the
+stack when they execute, too. In many other OO languages, including C++,
+instances contain information about their classes (a <a href="http://www.mvps.org/vbvision/vtable.htm">vtable</a>
+pointer, for example). By making this pairing explicit rather than implicit,
+Ficl can be OO about chunks of data that don't realize that they are objects,
+without sacrificing any robustness for native objects. That means that
+you can use Ficl to write object wrappers for data structures created in
+C or assembly language, as long as you can determine how they're laid out
+in memory.
+<p>
+
+Whenever you create an object in Ficl, you specify its class.
+After that, the object always pushes its class and the address of its
+<a href="http://www.aware.com/Glossary/main.htm#P">payload</a>
+(instance variable space) when invoked by name.
+<p>
+
+Classes are special kinds of objects that store the methods of their
+instances, the size of an instance's payload, and a parent class pointer.
+Classes themselves are instances of a special base class called <code>METACLASS</code>,
+and all classes inherit from class <code>OBJECT</code>. This is confusing at
+first, but it means that Ficl has a very simple syntax for constructing
+and using objects. Class methods include subclassing (<code>SUB</code>), creating
+initialized and uninitialized instances (<code>NEW</code> and <code>INSTANCE</code>),
+and creating reference instances (<code>REF</code>), described later. Classes
+also have methods for disassembling their methods (<code>SEE</code>), identifying
+themselves (<code>ID</code>), and listing their pedigree (<code>PEDIGREE</code>).
+All objects inherit (from <code>OBJECT</code>) methods for initializing instances
+and arrays of instances, for performing array operations, and for getting
+information about themselves.
+
+
+<p>
+</blockquote><table border=0 bgcolor=#d0d0d0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=3><b><i>
+<a name='MethodsAndMessages'>
+Methods And Messages
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Methods are the functions that objects execute in response to messages.
+A message is a request to an object for a behavior that the object supports.
+When it receives a message, the target object looks up a method that performs
+the behavior for its class, and executes it. Any specific message may be
+bound to different methods in different objects, according to class. This
+separation of messages and methods allows objects to behave <a href="http://www.whatis.com/polymorp.htm">polymorphically</a>.
+(In Ficl, methods are words defined in the context of a class, and messages
+are the names of those words.) Ficl classes associate messages with methods
+for their instances (a fancy way of saying that each class owns a wordlist).
+Ficl provides a late-binding operator <code>--></code> that sends messages
+to objects at run-time, and an early-binding operator <code>=></code>
+that compiles a specific class's method. These operators are the only supported
+way to invoke methods. Regular Forth words are not visible to the method-binding
+operators, so there's no chance of confusing a message with a regular
+word of the same name.
+
+<a NAME="ootutorial-finally"></a>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='Tutorial'>
+Tutorial
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+(Finally!)
+<p>
+
+This is a tutorial. It works best if you follow along by pasting the examples
+into <b>ficlWin</b>, the Win32 version of Ficl included with the release sources
+(or some other build that includes the OO part of <code>softcore.c</code>). If you're
+not familiar with Forth, please see one of these <a href="#links">references</a>.
+Ficl's OOP words are in vocabulary <code>OOP</code>. To put <code>OOP</code> in
+the search order and make it the compilation wordlist, type:
+<pre>
+ONLY
+ALSO OOP DEFINITIONS
+</pre>
+
+<b>Note for beginners:</b> To see the effect of the commands above, type
+<code>ORDER</code>
+after each line. You can repeat the sequence above if you like.
+<p>
+
+To start, we'll work with the two base classes <code>OBJECT</code> and <code>METACLASS</code>.
+Try this:
+<pre>
+METACLASS --> METHODS
+</pre>
+
+The line above contains three words. The first is the name of a class,
+so it pushes its signature on the stack. Since all classes are instances
+of <code>METACLASS</code>, <code>METACLASS</code> behaves as if it is an instance
+of itself (this is the only class with this property). It pushes the same
+address twice: once for the class and once for the payload, since they
+are the same. The next word finds a method in the context of a class and
+executes it. In this case, the name of the method is <code>METHODS</code>.
+Its job is to list all the methods that a class knows. What you get when
+you execute this line is a list of all the class methods Ficl provides.
+<pre>
+OBJECT --> SUB C-LED
+</pre>
+Causes the base-class <code>OBJECT</code> to derive from itself a new class
+called <code>C-LED</code>. Now we'll add some instance variables and methods to the new class.
+<p>
+
+<b>Note:</b> I like to prefix the names of classes with <code>c-</code> and the
+names of member variables with a period, but this is just a convention.
+If you don't like it, pick your own.
+<pre>
+C-BYTE OBJ: .STATE
+: INIT { 2:THIS -- }
+ THIS --> SUPER --> INIT
+ ." Initializing an instance of "
+ THIS --> CLASS --> ID TYPE CR ;
+: ON { LED# 2:THIS -- }
+ THIS --> .STATE --> GET
+ 1 LED# LSHIFT OR DUP !OREG
+ THIS --> .STATE --> SET ;
+: OFF { LED# 2:THIS -- }
+ THIS --> .STATE --> GET
+ 1 LED# LSHIFT INVERT AND DUP !OREG
+ THIS --> .STATE --> SET&NBSP; ;
+END-CLASS
+</pre>
+The first line adds an instance variable called <code>.STATE</code> to the
+class. This particular instance variable is an object&mdash;it will be an instance
+of <code>C-BYTE</code>, one of Ficl's stock classes (the source for which can be found
+in the distribution in <code>softcore/classes.fr</code>).
+<p>
+
+Next we've defined a method called <code>INIT</code>. This line also declares
+a <a href="locals.html">local variable</a> called <code>THIS</code>
+(the 2 in front tells Ficl that this is a double-cell local). All methods
+by convention expect the address of the class and instance on top of the
+stack when called. The next three lines define the behavior of <code>INIT</code> when it's called.
+It first calls its superclass's version of <code>INIT</code> (which in this
+case is "<code>OBJECT => INIT</code>"&mdash;this default implementation clears all
+instance variables). The rest displays some text and causes the instance
+to print its class name (<code>THIS --> CLASS --> ID</code>).
+<p>
+
+The <code>INIT</code>> method is special for Ficl objects: whenever
+you create an initialized instance using <code>NEW</code> or <code>NEW-ARRAY</code>,
+Ficl calls the class's <code>INIT</code> method for you on that instance. The
+default <code>INIT</code> method supplied by <code>OBJECT</code> clears the instance,
+so we didn't really need to override it in this case (see the source code
+in <code>softcore/oo.fr</code>).
+<p>
+
+The <code>ON</code> and <code>OFF</code> methods defined above hide the details
+of turning LEDs on and off. The interface to FiclWin's simulated hardware
+is handled by <code>!OREG</code>. The class keeps the LED state in a shadow
+variable (<code>.STATE</code>) so that <code>ON</code> and <code>OFF</code> can work
+in terms of LED number rather than a bitmask.
+<p>
+
+Now make an instance of the new class:
+<pre>
+C-LED --> NEW LED
+</pre>
+
+And try a few things...
+<pre>
+LED --> METHODS
+LED --> PEDIGREE
+1 LED --> ON
+1 LED --> OFF
+</pre>
+
+Or you could type this with the same effect:
+<pre>
+LED 2DUP --> METHODS --> PEDIGREE
+</pre>
+
+Notice (from the output of <code>METHODS</code>) that we've overridden the
+<code>INIT</code> method supplied by object, and added two more methods for the member
+variables. If you type <code>WORDS</code>, you'll see that these methods are
+not visible outside the context of the class that contains them. The method
+finder <code>--></code> uses the class to look up methods. You can use
+this word in a definition, as we did in <code>INIT</code>, and it performs
+late binding, meaning that the mapping from message (method name) to method
+(the code) is deferred until run-time. To see this, you can decompile the
+init method like this:
+<pre>
+C-LED --> SEE INIT
+</pre>
+
+or
+<pre>
+LED --> CLASS --> SEE INIT
+</pre>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='EarlyBinding'>
+Early Binding
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Ficl also provides early binding if you ask for it. Early binding is not
+as safe as late binding, but it produces code that is more compact and
+efficient because it compiles method addresses rather then their names.
+In the preferred uses of early binding, the class is assumed to be the
+one you're defining. This kind of early binding can only be used inside
+a class definition. Early bound methods still expect to find a class and
+instance cell-pair on top of the stack when they run.
+<p>
+
+Here's an example that illustrates a potential problem:
+<pre>
+OBJECT --> SUB C1
+: M1 { 2:THIS -- } ." C1'S M1" CR ;
+: M2 { 2:THIS -- } ." Running " THIS MY=> M1 ; ( early )
+: M3 { 2:THIS -- } ." Running " THIS --> M1 ( late )
+END-CLASS
+C1 --> SUB C2
+: M1 { 2:THIS -- } ." C2'S M1" CR ;
+END-CLASS
+C2 --> NEW I2
+I2 --> M1 ( runs the M1 defined in C2 )
+I2 --> M2 ( Is this what you wanted? )
+I2 --> M3 { runs the overridden M1)
+</pre>
+
+Even though we overrode method <code>M1</code> in class <code>C2</code>, the definition of <code>M2</code> with
+early binding forced the use of <code>M1</code> as defined in <code>C1</code>. If that's what you
+want, great, but more often you'll want the flexibility of overriding parent
+class behaviors appropriately.
+
+<ol>
+
+<li>
+<code>MY=></code> binds early to a method in the class being defined,
+as in the example above.
+
+<li>
+<code>MY=[ ]</code> binds a sequence of methods in the current class.
+Useful when the class has object members. Lines like
+<code>THIS --> STATE --> SET</code> in the definition of <code>C-LED</code> above can be replaced with
+<code>THIS MY=[ STATE SET ]</code> to use early binding.
+
+<li>
+<code>=></code> (dangerous) pops a class off the stack and compiles
+the method in that class. Since you have to specify the class explicitly,
+there is a real danger that this will be out of sync with the class you
+really wanted. I recommend you use <code>MY=></code> or <code>MY=[ ]</code> instead.
+
+</ol>
+
+Early binding using <code>=></code> is dangerous because it partially
+defeats the data-to-code matching mechanism object oriented languages were
+created to provide, but it does increase run-time speed by binding the
+method at compile time. In many cases, such as the <code>INIT</code> method,
+you can be reasonably certain of the class of thing you're working on.
+This is also true when invoking class methods, since all classes are instances
+of <code>METACLASS</code>. Here's an example from the definition of <code>METACLASS</code>
+in oo.fr (don't paste this into ficlWin&mdash;it's already there):
+<pre>
+: NEW \ ( class metaclass "name" -- )
+ METACLASS => INSTANCE --> INIT ;
+</pre>
+
+Try this:
+<pre>
+METACLASS --> SEE NEW
+</pre>
+
+Decompiling the method with <code>SEE</code> shows the difference between the
+two strategies. The early bound method is compiled inline, while the late-binding
+operator compiles the method name and code to find and execute it in the
+context of whatever class is supplied on the stack at run-time.
+<p>
+
+Notice that the primitive early-binding operator <code>=></code> requires
+a class at compile time. For this reason, classes are <code>IMMEDIATE</code>,
+meaning that they push their signature at compile time or run time. I'd
+recommend that you avoid early binding until you're very comfortable with
+Forth, object-oriented programming, and Ficl's OOP syntax.
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='MoreAboutInstanceVariables'>
+More About Instance Variables
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<i>Untyped</i> instance variable methods (created by <code>CELL: CELLS: CHAR:</code>
+and <code>CHARS:</code>) just push the address of the corresponding instance
+variable when invoked on an instance of the class. It's up to you to remember
+the size of the instance variable and manipulate it with the usual Forth
+words for fetching and storing.
+<p>
+
+As advertised earlier, Ficl provides ways to objectify existing data
+structures without changing them. Instead, you can create a Ficl class
+that models the structure, and instantiate a <i>ref</i> from this class,
+supplying the address of the structure. After that, the <i>ref instance</i>
+behaves as a Ficl object, but its instance variables take on the values
+in the existing structure. Example (from <code>softcore/ficlclass.fr</code>):
+<pre>
+OBJECT SUBCLASS C-WORDLIST
+ C-WORDLIST REF: .PARENT
+ C-PTR OBJ: .NAME
+ C-CELL OBJ: .SIZE
+ C-WORD REF: .HASH ( first entry in hash table )
+
+ : ?
+ --> GET-NAME ." ficl wordlist " TYPE CR ;
+ : PUSH DROP >SEARCH ;
+ : POP 2DROP PREVIOUS ;
+ : SET-CURRENT DROP SET-CURRENT ;
+ : GET-NAME DROP WID-GET-NAME ;
+ : WORDS { 2:THIS -- }
+ THIS MY=[ .SIZE GET ] 0 DO
+ I THIS MY=[ .HASH INDEX ] ( 2list-head )
+ BEGIN
+ 2DUP --> GET-NAME TYPE SPACE
+ --> NEXT OVER
+ 0= UNTIL 2DROP CR
+ LOOP
+ ;
+END-CLASS
+</pre>
+
+In this case, <code>C-WORDLIST</code> describes Ficl's wordlist structure;
+<code>NAMED-WID</code> creates a wordlist and binds it to a ref instance of
+<code>C-WORDLIST</code>.
+The fancy footwork with <code>POSTPONE</code> and early binding is required
+because classes are immediate. An equivalent way to define <code>NAMED-WID</code> with
+late binding is:
+<pre>
+: NAMED-WID ( c-address u -- )
+ WORDLIST POSTPONE C-WORDLIST --> REF
+ ;
+</pre>
+
+To do the same thing at run-time (and call it <code>MY-WORDLIST</code>):
+
+<pre>wordlist c-wordlist --> ref my-wordlist</pre>
+
+Now you can deal with the wordlist through the ref instance:
+<pre>
+MY-WORDLIST --> PUSH
+MY-WORDLIST --> SET-CURRENT
+ORDER
+</pre>
+
+Ficl can also model linked lists and other structures that contain pointers
+to structures of the same or different types. The class constructor word
+<a href="#exampleref:"><code>REF:</code></a>
+makes an aggregate reference to a particular class. See the <a href="#glossinstance">instance
+variable glossary</a> for an <a href="#exampleref:">example</a>.
+<p>
+
+Ficl can make arrays of instances, and aggregate arrays into class descripions.
+The <a href="#glossclass">class methods</a> <code>ARRAY</code> and <code>NEW-ARRAY</code>
+create uninitialized and initialized arrays, respectively, of a class.
+In order to initialize an array, the class must define (or inherit) a reasonable
+<code>INIT</code> method. <code>NEW-ARRAY</code> invokes it on each member of the array
+in sequence from lowest to highest. Array instances and array members use
+the object methods <code>INDEX</CODE>, <CODE>NEXT</CODE>, and <CODE>PREV</code>
+to navigate. Aggregate a member array of objects using <a href="#arraycolon"><code>ARRAY:</code></a>.
+The objects are not automatically initialized in this case&mdash;your class
+initializer has to call <code>ARRAY-INIT</code> explicitly if you want
+this behavior.
+<p>
+
+For further examples of OOP in Ficl, please see the source file <code>softcore/ficlclass.fr</code>.
+This file wraps several Ficl internal data structures in objects and gives
+use examples.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='FiclStringClasses'>
+Ficl String Classes
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a NAME="cstring"></a>
+
+<code>C-STRING</code> is a reasonably useful dynamic string class.
+Source code for the class is located in <code>softcore/string.fr</code>.
+Features:
+dynamic creation and resizing; deletion, char cout, concatenation, output,
+comparison; creation from quoted string constant (<code>S"</code>).
+<p>
+Examples of use:
+<pre>
+C-STRING --> NEW HOMER
+S" In this house, " HOMER --> SET
+S" we obey the laws of thermodynamics!" HOMER --> CAT
+HOMER --> TYPE
+</pre>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='OOPGlossary'>
+OOP Glossary
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<a NAME="oopgloss"></a>
+
+<b>Note:</b> With the exception of the binding operators (the first two definitions
+here), all of the words in this section are internal factors that you don't
+need to worry about. These words provide method binding for all classes
+and instances. Also described are supporting words and execution factors.
+All are defined in <code>softcore/oo.fr</code>.
+
+<dl>
+
+<dt><code>--> <i>( instance class "method-name" -- xn )</i></code><dd>
+
+
+
+Late binding: looks up and executes the given method in the context of
+the class on top of the stack.
+
+<dt><code>C-> <i>( instance class "method-name" -- xn exc )</i></code><dd>
+
+
+
+Late binding with <code>CATCH</code>: looks up and <code>CATCH</code>es the given
+method in the context of the class on top of the stack, pushes zero or
+exception code upon return.
+
+<dt><code>MY=> <i>compilation: ( "method-name" -- ) execution: ( instance class -- xn )</i></code><dd>
+
+
+
+Early binding: compiles code to execute the method of the class being defined.
+Only visible and valid in the scope of a <code>--> SUB</CODE> .. <CODE>END-CLASS</code>
+class definition.
+
+<dt><code>MY=[ <i>compilation: ( "obj1 obj2 .. method ]" -- ) execution: ( instance class -- xn )</i></code><dd>
+
+
+
+Early binding: compiles code to execute a chain of methods of the class
+being defined. Only visible and valid in the scope of a <code>--> SUB</CODE>
+.. <CODE>END-CLASS</code> class definition.
+
+<dt><code>=> <i>compilation: ( class metaclass "method-name" -- ) execution: ( instance class -- xn )</i></code><dd>
+
+
+
+Early binding: compiles code to execute the method of the class specified
+at compile time.
+
+<dt><code>do-do-instance <i></i></code><dd>
+
+
+
+When executed, causes the instance to push its <code>( INSTANCE CLASS )</code> stack
+signature. Implementation factor of <code>METACLASS --> SUB</code></b> .
+Compiles <code>.DO-INSTANCE</code> in the context of a class; <code>.DO-INSTANCE</code>
+implements the <code>DOES></code> part of a named instance.
+
+<dt><code>exec-method <i>( instance class c-address u -- xn )</i></code><dd>
+
+
+
+Given the address and length of a method name on the stack, finds
+the method in the context of the specified class and invokes it. Upon entry
+to the method, the instance and class are on top of the stack, as usual.
+If unable to find the method, prints an error message and aborts.
+
+<dt><code>find-method-xt <i>( class "method-name" -- class xt )</i></code><dd>
+
+
+
+Attempts to map the message to a method in the specified class. If successful,
+leaves the class and the execution token of the method on the stack. Otherwise
+prints an error message and aborts.
+
+<dt><code>lookup-method <i>( class c-address u -- class xt )</i></code><dd>
+
+
+
+Given the address and length of a method name on the stack, finds
+the method in the context of the specified class. If unable to find the
+method, prints an error message and aborts.
+
+<dt><code>parse-method <i>compilation: ( "method-name" -- ) execution: ( -- c-address u )</i></code><dd>
+
+
+
+Parse <code>"method-name"</code> from the input stream and compile code to push its length
+and address when the enclosing definition runs.
+</dl>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#d0d0d0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=3><b><i>
+<a name='InstanceVariableGlossary'>
+Instance Variable Glossary
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a NAME="glossinstance"></a>
+
+<b>Note:</b>: These words are only visible when creating a subclass! To
+create a subclass, use the <code>SUB</code> method on <code>OBJECT</code> or any
+class derived from it (<i>not</i> <code>METACLASS</code>). Source code for
+Ficl OOP is in <code>softcore/oo.fr</code>.
+<p>
+
+Instance variable words do two things: they create methods that do
+san action appropriate for the type of instance variable they represent,
+and they reserve space in the class template for the instance variable.
+We'll use the term <i>instance variable</i> to refer both to the method
+that gives access to a particular field of an object, and to the field
+itself. Rather than give esentially the same example over and over, here's
+one example that shows several of the instance variable construction words
+in use:
+
+<pre>
+OBJECT SUBCLASS C-EXAMPLE
+ CELL: .CELL0
+ C-4BYTE OBJ: .NCELLS
+ 4 C-4BYTE ARRAY: .QUAD
+ CHAR: .LENGTH
+ 79 CHARS: .NAME
+END-CLASS
+</pre>
+
+This class only defines instance variables, and it inherits some methods
+from <code>OBJECT</code>. Each untyped instance variable (<code>.CELL0</code>, <code>.LENGTH</code>,
+<code>.NAME</code>) pushes its address when executed. Each object instance variable
+pushes the address and class of the aggregate object. Similar to C, an
+array instance variable leaves its base address (and its class) when executed.
+The word <code>SUBCLASS</code> is shorthand for <code>--> sub</code> .
+
+<dl>
+
+<dt><code>CELL: <i>compilation: ( offset "name" -- offset ) execution: ( -- cell-address )</i></code><dd>
+
+
+
+Create an untyped instance variable one cell wide. The instance variable
+leaves its payload's address when executed.
+
+<dt><code>CELLS: <i>compilation: ( offset nCells "name" -- offset' ) execution: ( -- cell-address )</i></code><dd>
+
+
+
+Create an untyped instance variable <code>nCells</code> cells wide.
+
+<dt><code>CHAR: <i>compilation: ( offset "name" -- offset' ) execution: ( -- cell-address )</i></code><dd>
+
+
+
+Create an untyped member variable one character wide.
+
+<dt><code>CHARS: <i>compilation: ( offset nChars "name" -- offset' ) execution: ( -- cell-address )</i></code><dd>
+
+
+
+Create an untyped member variable <code>nChars</code> characters wide.
+
+<dt><code>OBJ: <i>compilation: ( offset class metaclass "name" -- offset' ) execution: ( -- instance class )</i></code><dd>
+
+
+
+Aggregate an uninitialized instance of <code>CLASS</code> as a member variable
+of the class under construction.
+
+<dt><code>ARRAY: <i>compilation: ( offset nObjects class metaclass "name" -- offset' ) execution: ( -- instance class )</i></code><dd>
+
+
+<a NAME="arraycolon"></a>
+
+Aggregate an uninitialized array of instances of the class specified as
+a member variable of the class under construction.
+
+<dt><code>EXAMPLEREF: <i>compilation: ( offset class metaclass "name" -- offset' ) execution: ( -- ref-instance ref-class )</i></code><dd>
+
+
+
+Aggregate a reference to a class instance. There is no way to set the value
+of an aggregated ref&mdash;it's meant as a way to manipulate existing data
+structures with a Ficl OO model. For example, if your system contains a
+linked list of 4 byte quantities, you can make a class that represents
+a list element like this:
+
+<pre>
+OBJECT SUBCLASS C-4LIST
+ C-4LIST REF: .LINK
+ C-4BYTE OBJ: .PAYLOAD
+END-CLASS
+
+ADDRESS-OF-EXISTING-LIST C-4LIST --> REF MYLIST
+</pre>
+
+<dd>
+The last line binds the existing structure to an instance of the class
+we just created. The link method pushes the link value and the class <code>C_4LIST</code>,
+so that the link looks like an object to Ficl and like a struct to C (it
+doesn't carry any extra baggage for the object model&mdash;the Ficl methods
+alone take care of storing the class information).
+<p>
+
+<b>Note:</b> Since a <code>REF:</code> aggregate can only support one class, it's good for
+modeling static structures, but not appropriate for polymorphism. If you
+want polymorphism, aggregate a <code>C_REF</code> (see <code>softcore/classes.fr</code> for source)
+into your class&mdash;it has methods to set and get an object.
+<p>
+
+By the way, it is also possible to construct a pair of classes that contain
+aggregate pointers to each other. Here's an example:
+
+<pre>
+OBJECT SUBCLASS AKBAR
+ SUSPEND-CLASS \ put akbar on hold while we define jeff
+
+OBJECT SUBCLASS JEFF
+ AKBAR REF: .SIGNIFICANT-OTHER
+ ( <i>... your additional methods here ...</i> )
+END-CLASS \ done with jeff
+
+AKBAR --> RESUME-CLASS \ resume defining akbar
+ JEFF REF: .SIGNIFICANT-OTHER
+ ( <i>... your additional methods here ...</i> )
+END-CLASS \ done with akbar
+</pre>
+
+</dl>
+
+<a NAME="glossclass"></a>
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='ClassMethodsGlossary'>
+Class Methods Glossary
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+These words are methods of <code>METACLASS</code>. They define the manipulations
+that can be performed on classes. Methods include various kinds of instantiation,
+programming tools, and access to member variables of classes. Source is
+in <code>softcore/oo.fr</code>.
+
+<dl>
+
+<dt><code>INSTANCE <i>( class metaclass "name" -- instance class )</i></code><dd>
+
+
+
+Create an uninitialized instance of the class, giving it the name specified.
+The method leaves the instance's signature on the stack (handy if you
+want to initialize). Example:
+
+<pre>
+C_REF --> INSTANCE UNINIT-REF 2DROP
+</pre>
+
+<dt><code>NEW <i>( class metaclass "name" -- )</i></code><dd>
+
+
+
+Create an initialized instance of class, giving it the name specified.
+This method calls <code>INIT</code> to perform initialization.
+
+<dt><code>ARRAY <i>( nObjects class metaclass "name" -- nObjects instance class )</i></code><dd>
+
+
+
+Create an array of <code>nObjects</code> instances of the specified class.
+Instances are not initialized. Example:
+
+<pre>
+10 C_4BYTE --> ARRAY 40-RAW-BYTES 2DROP DROP
+</pre>
+
+
+<dt><code>NEW-ARRAY <i>( nObjects class metaclass "name" -- )</i></code><dd>
+
+
+
+Creates an initialized array of <code>nObjects</code> instances of the class.
+Same syntax as <code>ARRAY</code>.
+
+<a NAME="alloc"></a>
+<dt><code>ALLOC <i>( class metaclass -- instance class )</i></code><dd>
+
+
+
+Creates an anonymous instance of <code>CLASS</code> from the heap (using a call
+to <code>ficlMalloc()</code> to get the memory). Leaves the payload and class addresses
+on the stack. Usage example:
+
+<pre>
+C-REF --> ALLOC 2CONSTANT INSTANCE-OF-REF
+</pre>
+<p>
+
+Creates a double-cell constant that pushes the payload and class address
+of a heap instance of <code>C-REF</code>.
+
+<a NAME="allocarray"></a>
+<dt><code>ALLOC-ARRAY <i>( nObjects class metaclass -- instance class )</i></code><dd>
+
+
+
+Same as <code>NEW-ARRAY</code>, but creates anonymous instances from the heap using
+a call to <code>ficlMalloc()</code>. Each instance is initialized using the class's
+<code>INIT</code> method.
+
+<a NAME="allot"></a>
+<dt><code>ALLOT <i>( class metaclass -- instance class )</i></code><dd>
+
+
+
+Creates an anonymous instance of <code>CLASS</code> from the dictionary. Leaves
+the payload and class addresses on the stack. Usage example:
+
+<pre>
+C-REF --> ALLOT 2CONSTANT INSTANCE-OF-REF
+</pre>
+
+<p>
+
+Creates a double-cell constant that pushes the payload and class address
+of a heap instance of <code>C-REF</code>.
+
+<a NAME="allotarray"></a>
+<dt><code>ALLOT-ARRAY <i>( nObjects class metaclass -- instance class )</i></code><dd>
+
+
+
+Same as <code>NEW-ARRAY</code>, but creates anonymous instances from the dictionary.
+Each instance is initialized using the class's <code>INIT</code> method.
+
+<dt><code>REF <i>( instance-address class metaclass "name" -- )</i></code><dd>
+
+
+
+Make a ref instance of the class that points to the supplied instance address.
+No new instance space is allotted. Instead, the instance refers to the
+address supplied on the stack forever afterward. For wrapping existing
+structures.
+
+
+<dt><code>SUB <i>( class metaclass -- old-wid address[size] size )</i></code><dd>
+
+
+
+Derive a subclass. You can add or override methods, and add instance variables.
+Alias: <code>SUBCLASS</code>. Examples:
+<p>
+
+<pre>
+C_4BYTE --> SUB C_SPECIAL4BYTE
+ ( <i>... your new methods and instance variables here ...</i> )
+END-CLASS
+</pre>
+
+or
+
+<pre>
+C_4BYTE SUBCLASS C_SPECIAL4BYTE
+ ( <i>... your new methods and instance variables here ...</i> )
+END-CLASS
+</pre>
+
+<dt><code>.SIZE <i>( class metaclass -- instance-size )</i></code><dd>
+
+
+
+Returns address of the class's instance size field, in address units. This
+is a metaclass member variable.
+
+<dt><code>.SUPER <i>( class metaclass -- superclass )</i></code><dd>
+
+
+
+Returns address of the class's superclass field. This is a metaclass member
+variable.
+
+<dt><code>.WID <i>( class metaclass -- wid )</i></code><dd>
+
+
+
+Returns the address of the class's wordlist ID field. This is a metaclass
+member variable.
+
+<dt><code>GET-SIZE <i>( -- instance-size )</i></code><dd>
+
+
+
+Returns the size of an instance of the class in address units. Imeplemented
+as follows:
+
+<pre>
+: GET-SIZE METACLASS => .SIZE @ ;
+</pre>
+
+<dt><code>GET-WID <i>( -- wid )</i></code><dd>
+
+
+
+Returns the wordlist ID of the class. Implemented as:
+
+<pre>
+: GET-WID METACLASS => .WID @ ;
+</pre>
+
+<dt><code>GET-SUPER <i>( -- superclass )</i></code><dd>
+
+
+
+Returns the class's superclass. Implemented as
+
+<pre>
+: GET-SUPER METACLASS => .super @ ;
+</pre>
+
+
+<dt><code>ID <i>( class metaclass -- c-address u )</i></code><dd>
+
+
+
+Returns the address and length of a string that names the class.
+
+
+<dt><code>METHODS <i>( class metaclass -- )</i></code><dd>
+
+
+
+Lists methods of the class and all its superclasses.
+
+
+<dt><code>OFFSET-OF <i>( class metaclass "name" -- offset )</i></code><dd>
+
+
+
+Pushes the offset from the instance base address of the named member variable.
+If the name is not that of an instance variable method, you get garbage.
+There is presently no way to detect this error. Example:
+
+<pre>
+metaclass --> offset-of .wid
+</pre>
+
+
+<dt><code>PEDIGREE <i>( class metaclass -- )</i></code><dd>
+
+
+
+
+Lists the pedigree of the class (inheritance trail).
+
+<dt><code>SEE <i>( class metaclass "name" -- )</i></code><dd>
+
+
+
+Decompiles the specified method&mdash;obect version of <code>SEE</code>, from the
+<code>TOOLS</code> wordset.
+
+</dl>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='codeOBJECT/codeBase-ClassMethodsGlossary'>
+<code>OBJECT</code> Base-Class Methods Glossary
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a NAME="objectgloss"></a>
+
+These are methods that are defined for all instances by the base class
+<code>OBJECT</code>.
+The methods include default initialization, array manipulations, aliases
+of class methods, upcasting, and programming tools.
+
+<dl>
+
+<dt><code>INIT <i>( instance class -- )</i></code><dd>
+
+
+
+Default initializer, called automatically for all instances created with
+<code>NEW</code>
+or <code>NEW-ARRAY</code>. Zero-fills the instance. You do not normally need
+to invoke <code>INIT</code> explicitly.
+
+<dt><code>ARRAYINIT <i>( nObjects instance class -- )</i></code><dd>
+
+
+
+Applies <code>INIT</code> to an array of objects created by <code>NEW-ARRAY</code>.
+Note that <code>ARRAY:</code> does not cause aggregate arrays to be initialized
+automatically. You do not normally need to invoke <code>ARRAY-INIT</code> explicitly.
+
+<dt><code>FREE <i>( instance class -- )</i></code><dd>
+
+
+
+Releases memory used by an instance previously created with <code>ALLOC</code>
+or <code>ALLOC-ARRAY</code>. <b>Note:</b> This method is not presently protected
+against accidentally deleting something from the dictionary. If you do
+this, Bad Things are likely to happen. Be careful for the moment to apply
+free only to instances created with <code>ALLOC</code> or <code>ALLOC-ARRAY</code>.
+
+<dt><code>CLASS <i>( instance class -- class metaclass )</i></code><dd>
+
+
+
+Convert an object signature into that of its class. Useful for calling
+class methods that have no object aliases.
+
+<dt><code>SUPER <i>( instance class -- instance superclass )</i></code><dd>
+
+
+
+Upcast an object to its parent class. The parent class of <code>OBJECT</code>
+is zero. Useful for invoking an overridden parent class method.
+
+<dt><code>PEDIGREE <i>( instance class -- )</i></code><dd>
+
+
+
+Display an object's pedigree&mdash;its chain of inheritance. This is an alias
+for the corresponding class method.
+
+<dt><code>SIZE <i>( instance class -- instance-size )</i></code><dd>
+
+
+
+Returns the size, in address units, of one instance. Does not know about
+arrays! This is an alias for the class method <code>GET-SIZE</code>.
+
+<dt><code>METHODS <i>( instance class -- )</i></code><dd>
+
+
+
+Class method alias. Displays the list of methods of the class and all superclasses
+of the instance.
+
+<dt><code>INDEX <i>( n instance class -- instance[n] class )</i></code><dd>
+
+
+
+Convert array-of-objects base signature into signature for array element
+n. No check for bounds overflow. Index is zero-based, like C, so
+
+<pre>
+0 MY-OBJ --> INDEX
+</pre>
+
+is equivalent to
+
+<pre>
+MY-OBJ
+</pre>
+
+Check out the <a href="#minusrot">description of <code>-ROT</code></a> for
+help in dealing with indices on the stack.
+
+<dt><code>NEXT <i>( instance[n] class -- instance[n+1] )</i></code><dd>
+
+
+
+Convert an array-object signature into the signature of the next
+object in the array. No check for bounds overflow.
+
+<dt><code>PREV <i>( instance[n] class -- instance[n-1] class )</i></code><dd>
+
+
+
+Convert an object signature into the signature of the previous object
+in the array. No check for bounds underflow.
+
+</dl>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='SuppliedClasses'>
+Supplied Classes
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a NAME="stockclasses"></a>
+
+For more information on theses classes, see <code>softcore/classes.fr</code>.
+
+<dl>
+
+<dt><code>METACLASS <i></i></code><dd>
+
+
+
+Describes all classes of Ficl. Contains class methods. Should never be
+directly instantiated or subclassed. Defined in <code>softcore/oo.fr</code>. Methods described
+above.
+
+<dt><code>OBJECT <i></i></code><dd>
+
+
+
+Mother of all Ficl objects. Defines default initialization and array indexing
+methods. Defined in <code>softcore/oo.fr</code>. Methods described above.
+
+<dt><code>C-REF <i></i></code><dd>
+
+
+
+Holds the signature of another object. Aggregate one of these into a data
+structure or container class to get polymorphic behavior. Methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- ref-instance ref-class )</i></code><dd>
+
+
+Push the referenced object value on the stack.
+
+<dt><code>SET <i>( ref-instance ref-class instance class -- )</i></code><dd>
+
+
+Set the referenced object being held.
+
+<dt><code>.INSTANCE <i>( instance class -- a-address )</i></code><dd>
+
+
+Cell member that holds the instance.
+
+<dt><code>.CLASS <i>( instance class -- a-address )</i></code><dd>
+
+
+Cell member that holds the class.
+
+</dl>
+
+<dt><code>C-BYTE <i></i></code><dd>
+
+
+
+Primitive class derived from <code>OBJECT</code>, with a 1-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- byte )</i></code><dd>
+
+
+Push the object's value on the stack.
+
+<dt><code>SET <i>( byte instance class -- )</i></code><dd>
+
+
+Set the object's value from the stack.
+
+<dt><code>.PAYLOAD <i>( instance class -- address )</i></code><dd>
+
+
+Member holds instance's value.
+
+</dl>
+
+<dt><code>C-2BYTE <i></i></code><dd>
+
+
+
+Primitive class derived from <code>OBJECT</code>, with a 2-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- 2byte )</i></code><dd>
+
+
+Push the object's value on the stack.
+
+<dt><code>SET <i>( 2byte instance class -- )</i></code><dd>
+
+
+Set the object's value from the stack.
+
+<dt><code>.PAYLOAD <i>( instance class -- address )</i></code><dd>
+
+
+Member holds instance's value.
+
+</dl>
+
+<dt><code>C-4BYTE <i></i></code><dd>
+
+
+Primitive class derived from <code>object</code>, with a 4-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- 4byte )</i></code><dd>
+
+
+Push the object's value on the stack.
+
+<dt><code>SET <i>( 4byte instance class -- )</i></code><dd>
+
+
+Set the object's value from the stack.
+
+<dt><code>.PAYLOAD <i>( instance class -- address )</i></code><dd>
+
+
+Member holds instance's value.
+
+</dl>
+
+<dt><code>C-CELL <i></i></code><dd>
+
+
+
+Primitive class derived from <code>OBJECT</code>, with a cell payload (equivalent
+to <code>C-4BYTE</code> on 32 bit platforms, 64 bits wide on Alpha and other
+64-bit platforms). <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- 4byte )</i></code><dd>
+
+
+Push the object's value on the stack.
+
+<dt><code>SET <i>( 4byte instance class -- )</i></code><dd>
+
+
+Set the object's value from the stack.
+
+<dt><code>.PAYLOAD <i>( instance class -- address )</i></code><dd>
+
+
+Member holds instance's value.
+
+</dl>
+
+<dt><code>C-PTR <i></i></code><dd>
+
+
+
+Base class derived from <code>OBJECT</code> for pointers to non-object types.
+This class is not complete by itself: several methods depend on a derived
+class definition of <code>@SIZE</code>. Methods and members:
+
+<dl>
+
+<dt><code>.ADDR <i>( instance class -- a-address )</i></code><dd>
+
+
+Member variable, holds the pointer address.
+
+<dt><code>GET-PTR <i>( instance class -- pointer )</i></code><dd>
+
+
+Pushes the pointer address.
+
+<dt><code>SET-PTR <i>( pointer instance class -- )</i></code><dd>
+
+
+Sets the pointer address.
+
+<dt><code>INC-PTR <i>( instance class -- )</i></code><dd>
+
+
+Adds <code>@SIZE</code> to the pointer address.
+
+<dt><code>DEC-PTR <i>( instance class -- )</i></code><dd>
+
+
+Subtracts <code>@SIZE</code> to the pointer address.
+
+<dt><code>INDEX-PTR <i>( i instance class -- )</i></code><dd>
+
+
+Adds <code>i * @SIZE</code> to the pointer address.
+
+</dl>
+
+<dt><code>C-BYTEPTR <i></i></code><dd>
+
+
+
+Pointer to byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<dt><code>@SIZE <i>( instance class -- size )</i></code><dd>
+
+
+Push size of the pointed-to object.
+
+<dt><code>GET <i>( instance class -- byte )</i></code><dd>
+
+
+Pushes the pointer's referent byte.
+
+<dt><code>SET <i>( byte instance class -- )</i></code><dd>
+
+
+Stores <code>byte</code> at the pointer address.
+
+</dl>
+
+
+
+<dt><code>C-2BYTEPTR <i></i></code><dd>
+
+
+
+Pointer to 2byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<dt><code>@SIZE <i>( instance class -- size )</i></code><dd>
+
+
+Push size of the pointed-to object.
+
+<dt><code>GET <i>( instance class -- 2byte )</i></code><dd>
+
+
+Pushes the pointer's referent 2byte.
+
+<dt><code>SET <i>( 2byte instance class -- )</i></code><dd>
+
+
+Stores <code>2byte</code> at the pointer address.
+
+</dl>
+
+
+
+<dt><code>C-4BYTEPTR <i></i></code><dd>
+
+
+
+Pointer to 4byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<dt><code>@SIZE <i>( instance class -- size )</i></code><dd>
+
+
+Push size of the pointed-to object.
+
+<dt><code>GET <i>( instance class -- 4byte )</i></code><dd>
+
+
+Pushes the pointer's referent 4byte.
+
+<dt><code>SET <i>( 4byte instance class -- )</i></code><dd>
+
+
+Stores <code>4byte</code> at the pointer address.
+
+</dl>
+
+
+<dt><code>C-CELLPTR <i></i></code><dd>
+
+
+
+Pointer to cell derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<dt><code>@SIZE <i>( instance class -- size )</i></code><dd>
+
+
+Push size of the pointed-to object.
+
+<dt><code>GET <i>( instance class -- cell )</i></code><dd>
+
+
+Pushes the pointer's referent cell.
+
+<dt><code>SET <i>( cell instance class -- )</i></code><dd>
+
+
+Stores <code>cell</code> at the pointer address.
+
+</dl>
+
+
+
+<dt><code>C-STRING <i></i></code><dd>
+
+
+
+Dynamically allocated string, similar to MFC's <code>CString</code>.
+For more information, see <code>softcore/string.fr</code>.
+Partial list of methods and members:
+
+<dl>
+
+<dt><code>GET <i>( instance class -- c-address u )</i></code><dd>
+
+
+Pushes the string buffer's contents as a <code>C-ADDR U</code> style string.
+
+<dt><code>SET <i>( c-address u instance class -- )</i></code><dd>
+
+
+Sets the string buffer's contents to a new value.
+
+<dt><code>CAT <i>( c-address u instance class -- )</i></code><dd>
+
+
+Concatenates a string to the string buffer's contents.
+
+<dt><code>COMPARE <i>( c-address u instance class -- result )</i></code><dd>
+
+
+Lexical compiration of a string to the string buffer's contents.
+Return value is the same as the FORTH function <code>COMPARE</code>.
+
+<dt><code>TYPE <i>( instance class -- )</i></code><dd>
+
+
+Prints the contents of the string buffer to the output stream.
+
+<dt><code>HASHCODE <i>( instance class -- i )</i></code><dd>
+
+
+Returns a computed hash based on the contents of the string buffer.
+
+<dt><code>FREE <i>( instance class -- )</i></code><dd>
+
+
+Releases the internal buffer.
+
+</dl>
+
+
+<dt><code>C-HASHSTRING <i></i></code><dd>
+
+
+
+Subclass of <code>C-STRING</code>, which adds a member variable to store a hashcode.
+For more information, see <code>softcore/string.fr</code>.
+
+</dl>
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/parsesteps.html b/doc/parsesteps.html
new file mode 100644
index 000000000000..522ae656d638
--- /dev/null
+++ b/doc/parsesteps.html
@@ -0,0 +1,388 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl parse steps</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl parse steps
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='ParseSteps'>
+Parse Steps
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Unlike every other FORTH we know of, Ficl features an <i>extensible
+parser chain</i>. The Ficl parser is not a monolithic function; instead,
+it is comprised of a simple tokenizer and a series of <i>parse steps</i>.
+A parse step is a step in the parser chain that handles a particular kind
+of token, acting on the token as appropriate. Example parse steps, in
+terms of traditional FORTH lore, would be the "number runner" and the
+"colon compiler".
+<p>
+
+The Ficl parser works like this:
+<ol>
+
+<li>
+Read in a new <i>token</i> (string of text with no internal whitespace).
+
+<li>
+For each parse step in the chain, call the parse step, passing in the token.
+If the parse step returns <code>FICL_TRUE</code>, that parse step must have
+handled the token appropriately; move on to the next token.
+
+<li>
+If the parser tries all the parse steps and none of them return
+<code>FICL_TRUE</code>, the token is illegal&mdash;print an error
+and reset the virtual machine.
+
+</ol>
+
+Parse steps can be written as native functions, or as Ficl script functions.
+New parse steps can be appended to the chain at any time.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='TheDefaultFiclParseChain'>
+The Default Ficl Parse Chain
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+These is the default Ficl parser chain, shown in order.
+
+<dl>
+
+<dt>
+<code>?word</code>
+<dd>
+
+
+
+If compiling and local variable support is enabled, attempt to find the token in the local
+variable dictionary. If found, execute the token's compilation semantics and return <code>FICL_TRUE</code>.
+<p>
+
+Attempt to find the token in the system dictionary. If found, execute the token's semantics
+(may be different when compiling than when interpreting) and return <code>FICL_TRUE</code>.
+
+<dt>
+<code>?prefix</code>
+<dd>
+
+
+This parse step is only active if prefix support is enabled, setting <code>FICL_WANT_PREFIX</code>
+in <code>ficl.h</code> to a non-zero value.
+Attempt to match the beginning of the token to the list of known prefixes. If there's a match,
+execute the associated prefix method and return <code>FICL_TRUE</code>.
+
+<dt>
+<code>?number</code>
+<dd>
+
+
+Attempt to convert the token to a number in the present <code>BASE</code>. If successful, push the
+value onto the stack if interpreting, otherwise compile it, then return <code>FICL_TRUE</code>.
+
+<dt>
+<code>?float</code>
+<dd>
+
+
+This parse step is only active if floating-point number support is enabled,
+setting <code>FICL_WANT_FLOAT</code> in <code>ficl.h</code> to a non-zero value.
+Attempt to convert the token to a floating-point number. If successful, push the
+value onto the floating-point stack if interpreting, otherwise compile it,
+then return <code>FICL_TRUE</code>.
+
+</dl>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='AddingAParseStepFromWithinFicl'>
+Adding A Parse Step From Within Ficl
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<a name=ficlparsestep></a>
+
+You can add a parse step in two ways. The first is to write a Ficl word that
+has the correct stack signature for a parse step:
+<pre>
+<i>MY-PARSE-STEP</i> ( c-addr u -- x*i flag )
+</pre>
+where <code>c-addr u</code> are the address and length of the incoming token,
+and <code>flag</code> is <code>FICL_TRUE</code> if the parse step processed
+the token and <code>FICL_FALSE</code> otherwise.
+<p>
+
+Install the parse step using <code>add-parse-step</code>.
+A trivial example:
+<pre>
+: ?silly ( c-addr u -- flag )
+ ." Oh no! Not another " type cr true ;
+' ?silly add-parse-step
+parse-order
+</pre>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='AddingANativeParseStep'>
+Adding A Native Parse Step
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+The other way to add a parse step is to write it in C and add it into the
+parse chain with the following function:
+
+<pre>
+void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep step);
+</pre>
+
+<code>name</code> is the display name of the parse step in the parse chain
+(as displayed by the Ficl word <code>PARSE-ORDER</code>). <code>step</code>
+is a pointer to the code for the parse step itself,
+and must match the following declaration:
+<pre>
+typedef int (*ficlParseStep)(ficlVm *vm, ficlString s);
+</pre>
+<p>
+
+When a native parse step is run, <code>si</code> points to the incoming token.
+The parse step must return <code>FICL_TRUE</code> if it succeeds in handling the
+token, and <code>FICL_FALSE</code> otherwise.
+See <code>ficlVmParseNumber()</code> in <code>system.c</code> for an example.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Prefixes'>
+Prefixes
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+What's a prefix, anyway? A prefix (contributed by Larry Hastings) is a token that's
+recognized as the beginning of another token. Its presence modifies the semantics of
+the rest of the token. An example is <code>0x</code>, which causes digits following
+it to be converted to hex regardless of the current value of <code>BASE</code>.
+<p>
+
+Caveat: Prefixes are matched in sequence, so the more of them there are,
+the slower the interpreter gets. On the other hand, because the prefix
+parse step occurs immediately after the dictionary lookup step, if you
+have a prefix for a particular purpose, using it may save time since it
+stops the parse process. Also, the Ficl interpreter is wonderfully fast,
+and most interpretation only happens once, so it's likely you won't notice
+any change in interpreter speed even if you make heavy use of prefixes.
+<p>
+
+Each prefix is a Ficl word stored in a special wordlist called <code>&lt;PREFIXES&gt;</code>. When the
+prefix parse step (<code>?prefix</code>, implemented in C as <code>ficlVmParsePrefix()</code>) is
+executed, it searches each word in <code>&lt;PREFIXES&gt;</code> in turn, comparing it with the
+initial characters of the incoming token. If a prefix matches, the parse step returns the remainder
+of the token to the input stream and executes the code associated with the prefix. This code can be
+anything you like, but it would typically do something with the remainder of the token. If the prefix
+code does not consume the rest of the token, it will go through the parse process again (which may
+be what you want).
+<p>
+
+Prefixes are defined in <code>prefix.c</code> and in <code>softcore/prefix.fr</code>.
+The best way to add prefixes is by defining them in your own code, bracketed with the special
+words <code>START-PREFIXES</code> and <code>END-PREFIXES</code>. For example, the following
+code would make <code>.(</code> a prefix.
+
+<pre>
+start-prefixes
+: .( .( ;
+end-prefixes
+</pre>
+<p>
+
+The compile-time constant <code>FICL_EXTENDED_PREFIX</code> controls the inclusion of
+several additional prefixes. This is turned off in the default build, since several
+of these prefixes alter standard behavior, but you might like them.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Notes'>
+Notes
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+
+<li>
+Prefixes and parser extensions are non-standard. However, with the exception of
+prefix support, Ficl's default parse order follows the standard.
+Inserting parse steps in some other order will almost certainly break standard behavior.
+<p>
+
+<li>
+The number of parse steps that can be added to the system is limited by the value of
+<code>FICL_MAX_PARSE_STEPS</code> (defined in <code>sysdep.h</code>). The default
+maximum number is 8.
+<p>
+
+<li>
+The compile-time constant <code>FICL_EXTENDED_PREFIX</code> controls the inclusion of
+several additional prefixes. This is turned off in the default build, since several
+of these prefixes alter standard behavior, but you might like them.
+<p>
+
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='ParserGlossary'>
+Parser Glossary
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<dl>
+
+<dt>
+<code>PARSE-ORDER ( -- )</code>
+<dd>
+
+
+
+Prints the list of parse steps, in the order in which they are called.
+
+<dt>
+<code>ADD-PARSE-STEP ( xt -- )</code>
+<dd>
+
+
+
+Appends a parse step to the parse chain. <code>xt</code> is the address
+(execution token) of a Ficl word to use as the parse step. The word must be a
+legal Ficl parse step (<a href=#ficlparsestep>see above</a>).
+
+<dt>
+<code>SHOW-PREFIXES ( -- )</code>
+<dd>
+
+
+
+Prints the list of all prefixes. Each prefix is a Ficl word that is executed if its name
+is found at the beginning of a token.
+
+<dt>
+<code>START-PREFIXES ( -- )</code>
+<dd>
+
+
+
+Declares the beginning of a series of prefix definitions.
+Should be followed, eventually, by <code>END-PREFIXES</code>.
+(All <code>START-PREFIXES</code> does is tell the Ficl virtual machine
+to compile into the <code>&lt;PREFIXES&gt;</code> wordlist.)
+
+<dt>
+<code>END-PREFIXES ( -- )</code>
+<dd>
+
+
+
+Declares the end of a series of prefix definitions.
+Should only be used after calling <code>START-PREFIXES</code>.
+(All <code>END-PREFIXES</code> does is tell the Ficl virtual machine
+to switch back to the wordlist that was in use before <code>START-PREFIXES</code> was called.)
+
+</dl>
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
diff --git a/doc/primer.txt b/doc/primer.txt
deleted file mode 100644
index 7de5214dd379..000000000000
--- a/doc/primer.txt
+++ /dev/null
@@ -1,1164 +0,0 @@
- A Beginner's Guide to Forth
-
- by
-
- J.V. Noble
-
- Contents
-
- 0. Preliminaries
-
-
- 1. Getting started
-
- The structure of Forth
-
- 2. Extending the dictionary
-
- 3. Stacks and reverse Polish notation (RPN)
- 3.1 Manipulating the parameter stack
- 3.2 The return stack and its uses
-
- 4. Fetching and storing
-
- 5. Comparing and branching
-
- 6. Documenting and commenting Forth code
-
- 7. Arithmetic operations
-
- 8. Looping and structured programming
-
- 9. CREATE ... DOES> (the pearl of Forth)
- 9.1 Defining "defining" words
- 9.2 Run-time vs. compile-time actions
- 9.3 Dimensioned data (intrinsic units)
- 9.4 Advanced uses of the compiler
-
- 10. Floating point arithmetic
-
-
-
- 0. Introduction
-
- Forth is an unusual computer language that has probably been applied
- to more varied projects than any other. It is the obvious choice when
- the project is exceptionally demanding in terms of completion sched-
- ule, speed of execution, compactness of code, or any combination of
- the above.
-
- It has also been called "...one of the best-kept secrets in the com-
- puting world." This is no exaggeration: large corporations have pur-
- chased professional Forth development systems from vendors such as
- Laboratory Microsystems, Inc., Forth, Inc. or MicroProcessor Engineer-
- ing, Ltd. and sworn them to secrecy.
-
- Some speculate (unkindly) that corporate giants prefer to hide their
- shame at using Forth; but I believe they are actually concealing a
- secret weapon from their rivals. Whenever Forth has competed directly
- with a more conventional language like C it has won hands down, pro-
- ducing smaller, faster, more reliable code in far less time. I have
- searched for examples with the opposite outcome, but have been unable
- to find a single instance.
-
-
-
- 1. Getting started
-
- We will use Win32Forth for these illustrations. Download the file
-
- w32for35.exe
-
- and double-click on it to install on any Windows 95-equipped machine.
-
-
- The compressed files will then decompress themselves. They should also
- install a program group on your desktop.
-
- Now start Win32Forth by opening the program group and clicking on the
- appropriate icon.
-
-
- It should respond by opening a window and writing something like
-
- 32bit Forth for Windows 95, and NT
- Compiled: July 23rd, 1997, 5:11pm
- Version: 3.5 Build: 0008 Release Build
- Platform: Windows 95 Version: 4.0 Build: 16384
- 491k bytes free
- 2,719 Words in Application dictionary
- 1,466 Words in System dictionary
- 4,185 Words total in dictionaries
- 8,293 Windows Constants available
-
- Loading Win32For.CFG
-
- *** DON'T PANIC, Press: F1 NOW! ***
-
-
- Win32Forth is case-insensitive.
-
-
- Now type
-
- BYE <cr>.
-
- The Win32Forth window immediately closes.
-
-
- What just happened? Forth is an interactive programming language con-
- sisting entirely of subroutines, called "words".
-
- A word is executed (interactively) by naming it. We have just seen
- this happen: BYE is a Forth subroutine meaning "exit to the operating
- system". So when we entered BYE it was executed, and the system re-
- turned control to Windows.
-
-
- Click on the Win32Forth icon again to re-start Forth.
- Now we will try something a little more complicated. Enter
-
- 2 17 + . <cr> 19 ok
-
- What happened? Forth is interpretive. An "outer interpreter" continu-
- ally loops, waiting for input from the keyboard or mass storage de-
- vice. The input is a sequence of text strings separated from each
- other by blank spaces --ASCII 32decimal = 20hex-- the standard Forth
- delimiter.
-
- When the outer interpreter encounters text it first looks for it in
- the "dictionary" (a linked list of previously defined subroutine
- names). If it finds the word, it executes the corresponding code.
-
- If no dictionary entry exists, the interpreter tries to read the input
- as a number.
-
- If the input text string satisfies the rules defining a number, it is
- converted to a number and stored in a special memory location called
- "the top of the stack" (TOS).
-
-
- In the above example, Forth interpreted 2 and 17 as numbers, and
- pushed them both onto the stack.
-
- "+" is a pre-defined word as is ".", so they were looked up and exe-
- cuted.
-
- "+" added 2 to 17 and left 19 on the stack.
-
- The word "." (called "emit") removed 19 from the stack and displayed
- it on the standard output device (in this case, CRT).
-
-
- We might also have said
-
- HEX 0A 14 * . <cr> C8 ok
-
- (Do you understand this? Hint: DECIMAL means "switch to decimal arith-
- metic", whereas HEX stands for "switch to hexadecimal arithmetic".)
-
- If the incoming text can neither be located in the dictionary nor in-
- terpreted as a number, Forth issues an error message. Try it: say X
- and see
-
- X
- Error: X is undefined
-
- or say THING and see
-
- THING
- Error: THING is undefined
-
-
-
- 2. Extending the dictionary
-
- The compiler is one of Forth's most endearing features. Unlike
- all other high-level languages, the Forth compiler is part of the
- language. (LISP and its dialects also make components of the com-
- pilation mechanism available to the programmer.) That is, its com-
- ponents are Forth words available to the programmer, that can be
- used to solve his problems.
-
- In this section we discuss how the compiler extends the
- dictionary.
-
- Forth uses special words to create new dictionary entries, i.e.,
- new words. The most important are ":" ("start a new definition")
- and ";" ("terminate the definition").
-
- Let's try this out: enter
-
- : *+ * + ; <cr> ok
-
- What happened? The word ":" was executed because it was already
- in the dictionary. The action of ":" is
-
- > Create a new dictionary entry named "*+" and switch from
- interpret to compile mode.
-
- > In compile mode, the interpreter looks up words and
- --rather than executing them-- installs pointers to
- their code. (If the text is a number, rather than
- pushing it on the stack, Forth builds the number
- into the dictionary space allotted for the new word,
- following special code that puts it on the stack
- when the word is executed.)
-
- > The action of "*+" will be to execute sequentially
- the previously-defined words "*" and "+".
-
- > The word ";" is special: when it was defined a bit
- was turned on in its dictionary entry to mark it as
- IMMEDIATE. Thus, rather than writing down its
- address, the compiler executes ";" immediately. The
- action of ";" is first, to install the code that
- returns control to the next outer level of the
- interpreter; and second, to switch back from compile
- mode to interpret mode.
-
- Now try out "*+" :
-
- DECIMAL 5 6 7 *+ . <cr> 47 ok
-
- This example illustrated two principles of Forth: adding a new word to
- the dictionary, and trying it out as soon as it was defined.
-
-
-
- 3. Stacks and reverse Polish notation (RPN)
-
- We now discuss the stack and the "reverse Polish" or "postfix" arith-
- metic based on it. (Anyone who has used a Hewlett-Packard calculator
- should be familiar with the concept.)
-
- Virtually all modern CPU's are designed around stacks. Forth effi-
- ciently uses its CPU by reflecting this underlying stack architecture
- in its syntax.
-
-
- But what is a stack? As the name implies, a stack is the machine ana-
- log of a pile of cards with numbers written on them. Numbers are
- always added to the top of the pile, and removed from the top of the
- pile. The Forth input line
-
- 2 5 73 -16 <cr> ok
-
- leaves the stack in the state
-
- cell # contents
-
-
- 0 -16 (TOS)
-
- 1 73 (NOS)
-
- 2 5
-
- 3 2
-
-
- where TOS stands for "top-of-stack", NOS for "next-on-stack", etc.
-
- We usually employ zero-based relative numbering in Forth data struct-
- ures (such as stacks, arrays, tables, etc.) so TOS is given relative
- #0, NOS #1, etc.
-
- Suppose we followed the above input line with the line
-
- + - * . <cr> xxx ok
-
- what would xxx be? The operations would produce the successive stacks
-
- cell# initial + - * .
-
- 0 -16 57 -52 -104
- 1 73 5 2
- 2 5 2
- 3 2 empty
- stack
-
- The operation "." (EMIT) displays -104 to the screen, leaving the
- stack empty. That is, xxx is -104.
-
-
- 3.1 Manipulating the parameter stack
-
- Forth systems incorporate (at least) two stacks: the parameter stack
- and the return stack.
-
- A stack-based system must provide ways to put numbers on the stack, to
- remove them, and to rearrange their order. Forth includes standard
- words for this purpose.
-
- Putting numbers on the stack is easy: simply type the number (or in-
- corporate it in the definition of a Forth word).
-
- The word DROP removes the number from TOS and moves up all the other
- numbers. (Since the stack usually grows downward in memory, DROP mere-
- ly increments the pointer to TOS by 1 cell.)
-
- SWAP exchanges the top 2 numbers.
-
- DUP duplicates the TOS into NOS.
-
- ROT rotates the top 3 numbers.
-
-
- These actions are shown below (we show what each word does to the ini-
- tial stack)
-
- cell | initial | DROP SWAP ROT DUP
-
- 0 | -16 | 73 73 5 -16
- 1 | 73 | 5 -16 -16 -16
- 2 | 5 | 2 5 73 73
- 3 | 2 | 2 2 5
- 4 | | 2
-
-
- Forth includes the words OVER, TUCK, PICK and ROLL that act as shown
- below (note PICK and ROLL must be preceded by an integer that says
- where on the stack an element gets PICK'ed or ROLL'ed):
-
- cell | initial | OVER TUCK 4 PICK 4 ROLL
-
- 0 | -16 | 73 -16 2 2
- 1 | 73 | -16 73 -16 -16
- 2 | 5 | 73 -16 73 73
- 3 | 2 | 5 5 5 5
- 4 | | 2 2 2
-
- Clearly, 1 PICK is the same as DUP, 2 PICK is a synonym for OVER, and
- 2 ROLL means SWAP.
-
-
- 3.2 The return stack and its uses
-
- We have remarked above that compilation establishes links from the
- calling word to the previously-defined word being invoked. The linkage
- mechanism --during execution-- uses the return stack (rstack): the
- address of the next word to be invoked is placed on the rstack, so
- that when the current word is done executing, the system knows to jump
- to the next word. (This is so in most, but not all Forth implement-
- ations. But all have a return stack, whether or not they use them for
- linking subroutines.)
-
- In addition to serving as a reservoir of return addresses (since words
- can be nested, the return addresses need a stack to be put on) the
- rstack is where the limits of a DO...LOOP construct are placed.
-
- The user can also store/retrieve to/from the rstack. This is an ex-
- ample of using a component for a purpose other than the one it was
- designed for. Such use is discouraged for novices since it adds the
- spice of danger to programming. See "Note of caution" below.
-
- To store to the rstack we say >R , and to retrieve we say R> . The
- word R@ copies the top of the rstack to the TOS.
-
-
- Why use the rstack when we have a perfectly good parameter stack to
- play with? Sometimes it becomes hard to read code that performs com-
- plex gymnastics on the stack. The rstack can reduce the complexity.
-
- Alternatively, VARIABLEs --named locations-- provide a place to store
- numbers --such as intermediate results in a calculation-- off the
- stack, again reducing the gymnastics. Try this:
-
- \ YOU DO THIS \ EXPLANATION
-
- VARIABLE X <cr> ok \ create a named storage location X;
- \ X executes by leaving its address
-
- 3 X ! <cr> ok \ ! ("store") expects a number and
- \ an address, and stores the number to
- \ that address
-
- X @ . <cr> 3 ok \ @ ("fetch") expects an address, and
- \ places its contents in TOS.
-
- However, Forth encourages using as few named variables as possible.
- The reason: since VARIABLEs are typically global --any subroutine can
- access them-- they can cause unwanted interactions among parts of a
- large program.
-
- Although Forth can make variables local to the subroutines that use
- them (see "headerless words" in FTR), the rstack can often replace
- local variables:
-
- > The rstack already exists, so it need not be defined anew.
-
- > When the numbers placed on it are removed, the rstack shrinks,
- reclaiming some memory.
-
-
- A note of caution: since the rstack is critical to execution we mess
- with it at our peril. If we use the rstack for temporary storage we
- must restore it to its initial state. A word that places a number on
- the rstack must remove it --using R> or RDROP (if it has been defined)
- -- before exiting that word. Since DO...LOOP also uses the rstack,
- for each >R folowing DO there must be a corresponding R> or RDROP
- preceding LOOP. Neglecting these precautions will probably crash
- the system.
-
-
-
-
- 4. Fetching and storing
-
- As we just saw, ordinary numbers are fetched from memory to
- the stack by @ ("fetch"), and stored by ! (store).
-
- @ expects an address on the stack and replaces that address by
- its contents using, e.g., the phrase X @
-
- ! expects a number (NOS) and an address (TOS) to store it in, and
- places the number in the memory location referred to by the address,
- consuming both arguments in the process, as in the phrase 3 X !
-
- Double length numbers can similarly be fetched and stored, by
- D@ and D!, if the system has these words.
-
- Positive numbers smaller than 255 can be placed in single bytes of
- memory using C@ and C!. This is convenient for operations with strings
- of ASCII text, for example screen and keyboard I/O.
-
-
-
- 5. Comparing and branching
-
- Forth lets you compare two numbers on the stack, using relational
- operators ">", "<", "=" . Ths, e.g., the phrase
-
- 2 3 > <cr> ok
-
- leaves 0 ("false") on the stack, because 2 (NOS) is not greater than 3
- (TOS). Conversely, the phrase
-
- 2 3 < <cr> ok
-
- leaves -1 ("true") because 2 is less than 3.
-
- Notes: In some Forths "true" is +1 rather than -1.
-
- Relational operators consume both arguments and leave a "flag"
- to show what happened.
-
- (Many Forths offer unary relational operators "0=", "0>" and "0<".
- These, as might be guessed, determine whether the TOS contains an
- integer that is 0, positive or negative.)
-
- The relational words are used for branching and control. For example,
-
- : TEST CR 0 = NOT IF ." Not zero!" THEN ;
-
- 0 TEST <cr> ok ( no action)
- -14 TEST <cr>
- Not zero! ok
-
- The word CR issues a carriage return (newline). Then TOS is compared
- with zero, and the logical NOT operator (this flips "true" and
- "false") applied to the resulting flag. Finally, if TOS is non-zero,
- IF swallows the flag and executes all the words between itself and the
- terminating THEN. If TOS is zero, execution jumps to the word
- following THEN.
-
- The word ELSE is used in the IF...ELSE...THEN statement: a nonzero
- value in TOS causes any words between IF and ELSE to be executed, and
- words between ELSE and THEN to be skipped. A zero value produces the
- opposite behavior. Thus, e.g.
-
-
- : TRUTH CR 0 = IF ." false" ELSE ." true" THEN ;
-
- 1 TRUTH <cr>
- true ok
-
- 0 TRUTH <cr>
- false ok
-
- Since THEN is used to terminate an IF statement rather than in its
- usual sense, some Forth writers prefer the name ENDIF.
-
- 6. Documenting and commenting Forth code
-
- Forth is sometimes accused of being a "write-only" language, i.e. some
- complain that Forth is cryptic. This is really a complaint against
- poor documentation and untelegraphic word names. Unreadability is
- equally a flaw of poorly written FORTRAN, PASCAL, C, etc.
-
- Forth offers programmers who take the trouble tools for producing ex-
- ceptionally clear code.
-
-
- 6.1 Parenthesized remarks
-
- The word ( -- a left parenthesis followed by a space -- says "disre-
- gard all following text until the next right parenthesis in the
- input stream". Thus we can intersperse explanatory remarks within
- colon definitions.
-
-
- 6.2 Stack comments
-
- A particular form of parenthesized remark describes the effect of a
- word on the stack. In the example of a recursive loop (GCD below),
- stack comments are really all the documentation necessary.
-
- Glossaries generally explain the action of a word with a
- stack-effect comment. For example,
-
- ( adr -- n)
-
- describes the word @ ("fetch"): it says @ expects to find an address
- (adr) on the stack, and to leave its contents (n) upon completion.
- The corresponding comment for ! would be
-
- ( n adr -- ) .
-
-
-
- 6.3 Drop line (\)
-
- The word "\" (back-slash followed by space) has recently gained favor
- as a method for including longer comments. It simply means "drop ev-
- erything in the input stream until the next carriage return". Instruc-
- tions to the user, clarifications or usage examples are most naturally
- expressed in a block of text with each line set off by "\" .
-
-
- 6.4 Self-documenting code
-
- By eliminating ungrammatical phrases like CALL or GOSUB, Forth pre-
- sents the opportunity --via telegraphic names for words-- to make code
- almost as self-documenting and transparent as a readable English or
- German sentence. Thus, for example, a robot control program could con-
- tain a phrase like
-
- 2 TIMES LEFT EYE WINK
-
- which is clear (although it sounds like a stage direction for Brun-
- hilde to vamp Siegfried). It would even be possible without much dif-
- ficulty to define the words in the program so that the sequence could
- be made English-like: WINK LEFT EYE 2 TIMES .
-
-
-
-
- 7. Arithmetic operations
-
- The 1979 or 1983 standards require that a conforming Forth system con-
- tain a certain minimum set of pre-defined words. These consist of
- arithmetic operators + - * / MOD /MOD */ for (usually) 16-bit signed-
- integer (-32767 to +32767) arithmetic, and equivalents for unsigned (0
- to 65535), double-length and mixed-mode (16- mixed with 32-bit) arith-
- metic. The list will be found in the glossary accompanying your
- system, as well as in SF and FTR.
-
- Try this example of a non-trivial program that uses arithmetic and
- branching to compute the greatest common divisor of two integers using
- Euclid's algorithm:
-
- : TUCK ( a b -- b a b) SWAP OVER ;
- : GCD ( a b -- gcd) ?DUP IF TUCK MOD GCD THEN ;
-
- The word ?DUP duplicates TOS if it is not zero, and leaves it alone
- otherwise. If the TOS is 0, therefore, GCD consumes it and does
- nothing else. However, if TOS is unequal to 0, then GCD TUCKs TOS
- under NOS (to save it); then divides NOS by TOS, keeping the remainder
- (MOD). There are now two numbers left on the stack, so we again take
- the GCD of them. That is, GCD calls itself. However, if you try the
- above code it will fail. A dictionary entry cannot be looked up and
- found until the terminating ";" has completed it. So in fact we must
- use the word RECURSE to achieve self-reference, as in
-
- : TUCK ( a b -- b a b) SWAP OVER ;
- : GCD ( a b -- gcd) ?DUP IF TUCK MOD RECURSE THEN ;
-
- Now try
-
- 784 48 GCD . 16 ok
-
-
- 8. Looping and structured programming
-
- Forth has several ways to loop, including the implicit method of re-
- cursion, illustrated above. Recursion has a bad name as a looping
- method because in most languages that permit recursion, it imposes
- unacceptable running time overhead on the program. Worse, recursion
- can --for reasons beyond the scope of this Introduction to Forth-- be
- an extremely inefficient method of expressing the problem. In Forth,
- there is virtually no excess overhead in recursive calls because Forth
- uses the stack directly. So there is no reason not to recurse if that
- is the best way to program the algorithm. But for those times when
- recursion simply isn't enough, here are some more standard methods.
-
- 8.1 Indefinite loops
-
- The construct
-
- BEGIN xxx ( -- flag) UNTIL
-
- executes the words represented by xxx, leaving TOS (flag) set to TRUE
- --at which point UNTIL terminates the loop-- or to FALSE --at which
- point UNTIL jumps back to BEGIN. Try:
-
- : COUNTDOWN ( n --)
- BEGIN CR DUP . 1 - DUP 0 = UNTIL DROP ;
-
- 5 COUNTDOWN
- 5
- 4
- 3
- 2
- 1 ok
-
- A variant of BEGIN...UNTIL is
-
- BEGIN xxx ( -- flag) WHILE yyy REPEAT
-
- Here xxx is executed, WHILE tests the flag and if it is FALSE
- leaves the loop; if the flag is TRUE, yyy is executed; REPEAT then
- branches back to BEGIN.
-
- These forms can be used to set up loops that repeat until some
- external event (pressing a key at the keyboard, e.g.) sets the
- flag to exit the loop. They can also used to make endless loops
- (like the outer interpreter of Forth) by forcing the flag
- to be FALSE in a definition like
-
-
- : ENDLESS BEGIN xxx FALSE UNTIL ;
-
-
- 8.2 Definite loops
-
- Most Forths allow indexed loops using DO...LOOP (or +LOOP or /LOOP).
- These are permitted only within definitions
-
- : BY-ONES ( n --) 0 TUCK DO CR DUP . 1 + LOOP DROP ;
-
- The words CR DUP . 1 + will be executed n times as the lower
- limit, 0, increases in unit steps to n-1.
-
- To step by 2's, we use the phrase 2 +LOOP to replace LOOP, as with
-
- : BY-TWOS ( n --) 0 TUCK
- DO CR DUP . 2 + 2 +LOOP DROP ;
-
-
- 8.4 Structured programming
-
- N. Wirth invented the Pascal language in reaction to program flow
- charts resembling a plate of spaghetti. Such flow diagrams were
- often seen in early languages like FORTRAN and assembler. Wirth
- intended to eliminate line labels and direct jumps (GOTOs), thereby
- forcing control flow to be clear and direct.
-
- The ideal was subroutines or functions that performed a single
- task, with unique entries and exits. Unfortunately, programmers
- insisted on GOTOs, so many Pascals and other modern languages now have
- them. Worse, the ideal of short subroutines that do one thing only is
- unreachable in such languages because the method for calling them and
- passing arguments imposes a large overhead. Thus execution speed re-
- quires minimizing calls, which in turn means longer, more complex sub-
- routines that perform several related tasks. Today structured program-
- ming seems to mean little more than writing code with nested IFs in-
- dented by a pretty-printer.
-
- Paradoxically, Forth is the only truly structured language in common
- use, although it was not designed with that as its goal. In Forth word
- definitions are subroutine calls. The language contains no GOTO's so
- it is impossible to write "spaghetti code". Forth also encourages
- structure through short definitions. The additional running time
- incurred in breaking a long procedure into many small ones (this is
- called "factoring") is typically rather small in Forth. Each Forth sub-
- routine (word) has one entry and one exit point, and can be written
- to perform a single job.
-
-
-
- 8.5 "Top-down" design
-
- "Top-down" programming is a doctrine that one should design the entire
- program from the general to the particular:
-
- > Make an outline, flow chart or whatever, taking a broad overview
- of the whole problem.
-
- > Break the problem into small pieces (decompose it).
-
- > Then code the individual components.
-
- The natural programming mode in Forth is "bottom-up" rather than "top-
- down" --the most general word appears last, whereas the definitions
- must progress from the primitive to the complex. This leads to a some-
- what different approach from more familiar languages:
-
- > In Forth, components are specified roughly, and then as they are
- coded they are immediately tested, debugged, redesigned and
- improved.
-
- > The evolution of the components guides the evolution of the outer
- levels of the program.
-
-
-
-
- 9. CREATE ... DOES> (the pearl of FORTH)
-
- Michael Ham has called the word pair CREATE...DOES>, the "pearl of
- Forth". CREATE is a component of the compiler, whose function is to
- make a new dictionary entry with a given name (the next name in the
- input stream) and nothing else. DOES> assigns a specific run-time ac-
- tion to a newly CREATEd word.
-
-
- 9.1 Defining "defining" words
-
- CREATE finds its most important use in extending the powerful class of
- Forth words called "defining" words. The colon compiler ":" is such
- a word, as are VARIABLE and CONSTANT.
-
- The definition of VARIABLE in high-level Forth is simple
-
- : VARIABLE CREATE 1 CELLS ALLOT ;
-
- We have already seen how VARIABLE is used in a program. (An altern-
- ative definition found in some Forths is
-
- : VARIABLE CREATE 0 , ;
-
- --these variables are initialized to 0.)
-
- Forth lets us define words initialized to contain specific values: for
- example, we might want to define the number 17 to be a word. CREATE
- and "," ("comma") can do this:
-
- 17 CREATE SEVENTEEN , <cr> ok
-
- Now test it via
-
- SEVENTEEN @ . <cr> 17 ok .
-
-
- Remarks:
-
- > The word , ("comma") puts TOS into the next cell of the dic-
- tionary and increments the dictionary pointer by that number of
- bytes.
-
- > A word "C," ("see-comma") exists also -- it puts a character into
- the next character-length slot of the dictionary and increments
- the pointer by 1 such slot. (If the character representation is
- ASCII the slots are 1 byte--Unicode requires 2 bytes.)
-
-
- 9.2 Run-time vs. compile-time actions
-
- In the preceding example, we were able to initialize the variable
- SEVENTEEN to 17 when we CREATEd it, but we still have to fetch it to
- the stack via SEVENTEEN @ whenever we want it. This is not quite what
- we had in mind: we would like to find 17 in TOS when SEVENTEEN is
- named. The word DOES> gives us the tool to do this.
-
- The function of DOES> is to specify a run-time action for the "child"
- words of a defining word. Consider the defining word CONSTANT , de-
- fined in high-level (of course CONSTANT is usually defined in machine
- code for speed) Forth by
-
- : CONSTANT CREATE , DOES> @ ;
-
- and used as
-
- 53 CONSTANT PRIME <cr> ok
-
- Now test it:
-
- PRIME . <cr> 53 ok .
-
-
- What is happening here?
-
- > CREATE (hidden in CONSTANT) makes an entry named PRIME (the
- first word in the input stream following CONSTANT). Then ","
- places the TOS (the number 53) in the next cell of the dic-
- tionary.
-
- > Then DOES> (inside CONSTANT) appends the actions of all words be-
- tween it and ";" (the end of the definition) --in this case, "@"--
- to the child word(s) defined by CONSTANT.
-
-
- 9.3 Dimensioned data (intrinsic units)
-
- Here is an example of the power of defining words and of the distinc-
- tion between compile-time and run-time behaviors.
-
- Physical problems generally involve quantities that have dimensions,
- usually expressed as mass (M), length (L) and time (T) or products of
- powers of these. Sometimes there is more than one system of units in
- common use to describe the same phenomena.
-
- For example, U.S. or English police reporting accidents might use
- inches, feet and yards; while Continental police would use centimeters
- and meters. Rather than write different versions of an accident ana-
- lysis program it is simpler to write one program and make unit conver-
- sions part of the grammar. This is easy in Forth.
-
- The simplest method is to keep all internal lengths in millimeters,
- say, and convert as follows:
-
- : INCHES 254 10 */ ;
- : FEET [ 254 12 * ] LITERAL 10 */ ;
- : YARDS [ 254 36 * ] LITERAL 10 */ ;
- : CENTIMETERS 10 * ;
- : METERS 1000 * ;
-
- Note: This example is based on integer arithmetic. The word */
- means "multiply the third number on the stack by NOS, keeping
- double precision, and divide by TOS". That is, the stack com-
- ment for */ is ( a b c -- a*b/c).
-
-
- The usage would be
-
- 10 FEET . <cr> 3048 ok
-
-
- The word "[" switches from compile mode to interpret mode while com-
- piling. (If the system is interpreting it changes nothing.) The word
- "]" switches from interpret to compile mode.
-
- Barring some error-checking, the "definition" of the colon compiler
- ":" is just
-
- : : CREATE ] DOES> doLIST ;
-
- and that of ";" is just
-
- : ; next [ ; IMMEDIATE
-
- Another use for these switches is to perform arithmetic at compile-
- time rather than at run-time, both for program clarity and for easy
- modification, as we did in the first try at dimensioned data (that is,
- phrases such as
-
- [ 254 12 * ] LITERAL
-
- and
-
- [ 254 36 * ] LITERAL
-
- which allowed us to incorporate in a clear manner the number of
- tenths of millimeters in a foot or a yard.
-
-
- The preceding method of dealing with units required unnecessarily many
- definitions and generated unnecessary code. A more compact approach
- uses a defining word, UNITS :
-
- : D, ( hi lo --) SWAP , , ;
- : D@ ( adr -- hi lo) DUP @ SWAP 2 + @ ;
- : UNITS CREATE D, DOES> D@ */ ;
-
- Then we could make the table
-
- 254 10 UNITS INCHES
- 254 12 * 10 UNITS FEET
- 254 36 * 10 UNITS YARDS
- 10 1 UNITS CENTIMETERS
- 1000 1 UNITS METERS
-
- \ Usage:
- 10 FEET . <cr> 3048 ok
- 3 METERS . <cr> 3000 ok
- \ .......................
- \ etc.
-
- This is an improvement, but Forth permits a simple extension that
- allows conversion back to the input units, for use in output:
-
- VARIABLE <AS> 0 <AS> !
- : AS TRUE <AS> ! ;
- : ~AS FALSE <AS> ! ;
- : UNITS CREATE D, DOES> D@ <AS> @
- IF SWAP THEN
- */ ~AS ;
-
- \ UNIT DEFINITIONS REMAIN THE SAME.
- \ Usage:
- 10 FEET . <cr> 3048 ok
- 3048 AS FEET . <cr> 10 ok
-
-
-
- 9.4 Advanced uses of the compiler
-
- Suppose we have a series of push-buttons numbered 0-3, and a word WHAT
- to read them. That is, WHAT waits for input from a keypad: when button
- #3 is pushed, for example, WHAT leaves 3 on the stack.
-
- We would like to define a word BUTTON to perform the action of pushing
- the n'th button, so we could just say:
-
- WHAT BUTTON
-
- In a conventional language BUTTON would look something like
-
- : BUTTON DUP 0 = IF RING DROP EXIT THEN
- DUP 1 = IF OPEN DROP EXIT THEN
- DUP 2 = IF LAUGH DROP EXIT THEN
- DUP 3 = IF CRY DROP EXIT THEN
- ABORT" WRONG BUTTON!" ;
-
- That is, we would have to go through two decisions on the average.
-
- Forth makes possible a much neater algorithm, involving a "jump
- table". The mechanism by which Forth executes a subroutine is to
- feed its "execution token" (often an address, but not necessarily)
- to the word EXECUTE. If we have a table of execution tokens we need
- only look up the one corresponding to an index (offset into the table)
- fetch it to the stack and say EXECUTE.
-
- One way to code this is
-
- CREATE BUTTONS ' RING , ' OPEN , ' LAUGH , ' CRY ,
- : BUTTON ( nth --) 0 MAX 3 MIN
- CELLS BUTTONS + @ EXECUTE ;
-
- Note how the phrase 0 MAX 3 MIN protects against an out-of-range
- index. Although the Forth philosophy is not to slow the code with un-
- necessary error checking (because words are checked as they are de-
- fined), when programming a user interface some form of error handling
- is vital. It is usually easier to prevent errors as we just did, than
- to provide for recovery after they are made.
-
- How does the action-table method work?
-
- > CREATE BUTTONS makes a dictionary entry BUTTONS.
-
- > The word ' ("tick") finds the execution token (xt) of the
- following word, and the word , ("comma") stores it in the
- data field of the new word BUTTONS. This is repeated until
- all the subroutines we want to select among have their xt's
- stored in the table.
-
- > The table BUTTONS now contains xt's of the various actions of
- BUTTON.
-
- > CELLS then multiplies the index by the appropriate number of
- bytes per cell, to get the offset into the table BUTTONS
- of the desired xt.
-
- > BUTTONS + then adds the base address of BUTTONS to get the abso-
- lute address where the xt is stored.
-
- > @ fetches the xt for EXECUTE to execute.
-
- > EXECUTE then executes the word corresponding to the button pushed.
- Simple!
-
- If a program needs but one action table the preceding method suffices.
- However, more complex programs may require many such. In that case
- it may pay to set up a system for defining action tables, including
- both error-preventing code and the code that executes the proper
- choice. One way to code this is
-
- : ;CASE ; \ do-nothing word
- : CASE:
- CREATE HERE -1 >R 0 , \ place for length
- BEGIN BL WORD FIND \ get next subroutine
- 0= IF CR COUNT TYPE ." not found" ABORT THEN
- R> 1+ >R
- DUP , ['] ;CASE =
- UNTIL R> 1- SWAP ! \ store length
- DOES> DUP @ ROT ( -- base_adr len n)
- MIN 0 MAX \ truncate index
- CELLS + CELL+ @ EXECUTE ;
-
- Note the two forms of error checking. At compile-time, CASE:
- aborts compilation of the new word if we ask it to point to an
- undefined subroutine:
-
- case: test1 DUP SWAP X ;case
- X not found
-
- and we count how many subroutines are in the table (including
- the do-nothing one, ;case) so that we can force the index to
- lie in the range [0,n].
-
- CASE: TEST * / + - ;CASE ok
- 15 3 0 TEST . 45 ok
- 15 3 1 TEST . 5 ok
- 15 3 2 TEST . 18 ok
- 15 3 3 TEST . 12 ok
- 15 3 4 TEST . . 3 15 ok
-
- Just for a change of pace, here is another way to do it:
-
- : jtab: ( Nmax --) \ starts compilation
- CREATE \ make a new dictionary entry
- 1- , \ store Nmax-1 in its body
- ; \ for bounds clipping
-
- : get_xt ( n base_adr -- xt_addr)
- DUP @ ( -- n base_adr Nmax-1)
- ROT ( -- base_adr Nmax-1 n)
- MIN 0 MAX \ bounds-clip for safety
- 1+ CELLS+ ( -- xt_addr = base + 1_cell + offset)
- ;
-
- : | ' , ; \ get an xt and store it in next cell
-
- : ;jtab DOES> ( n base_adr --) \ ends compilation
- get_xt @ EXECUTE \ get token and execute it
- ; \ appends table lookup & execute code
-
- \ Example:
- : Snickers ." It's a Snickers Bar!" ; \ stub for test
-
- \ more stubs
-
- 5 jtab: CandyMachine
- | Snickers
- | Payday
- | M&Ms
- | Hershey
- | AlmondJoy
- ;jtab
-
- 3 CandyMachine It's a Hershey Bar! ok
- 1 CandyMachine It's a Payday! ok
- 7 CandyMachine It's an Almond Joy! ok
- 0 CandyMachine It's a Snickers Bar! ok
- -1 CandyMachine It's a Snickers Bar! ok
-
-
-
- 10. Floating point arithmetic
-
- Although Forth at one time eschewed floating point arithmetic
- (because in the era before math co-processors integer arithmetic
- was 3x faster), in recent years a standard set of word names has
- been agreed upon. This permits the exchange of programs that will
- operate correctly on any computer, as well as the development of
- a Scientific Subroutine Library in Forth (FSL).
-
- Although the ANS Standard does not require a separate stack for
- floating point numbers, most programmers who use Forth for numer-
- ical analysis employ a separate floating point stack; and most of
- the routines in the FSL assume such. We shall do so here as well.
-
- The floating point operators have the following names and perform
- the actions indicated in the accompanying stack comments:
-
- F@ ( adr --) ( f: -- x)
- F! ( adr --) ( f: x --)
- F+ ( f: x y -- x+y)
- F- ( f: x y -- x-y)
- F* ( f: x y -- x*y)
- F/ ( f: x y -- x/y)
- FEXP ( f: x -- e^x)
- FLN ( f: x -- ln[x])
- FSQRT ( f: x -- x^0.5)
-
- Additional operators, functions, trigonometric functions, etc. can
- be found in the FLOATING and FLOATING EXT wordsets. (See dpANS6--
- available in HTML, PostScript and MS Word formats. The HTML version
- can be accessed from this homepage.)
-
- To aid in using floating point arithmetic I have created a simple
- FORTRAN-like interface for incorporating formulas into Forth words.
-
- The file ftest.f (included below) illustrates how ftran111.f
- should be used.
-
-\ Test for ANS FORmula TRANslator
-
-marker -test
-fvariable a
-fvariable b
-fvariable c
-fvariable d
-fvariable x
-fvariable w
-
-: test0 f" b+c" cr fe.
- f" b-c" cr fe.
- f" (b-c)/(b+c)" cr fe. ;
-
-3.e0 b f!
-4.e0 c f!
-see test0
-test0
-
-: test1 f" a=b*c-3.17e-5/tanh(w)+abs(x)" a f@ cr fe. ;
-1.e-3 w f!
--2.5e0 x f!
-cr cr
-see test1
-test1
-
-cr cr
-: test2 f" c^3.75" cr fe.
- f" b^4" cr fe. ;
-see test2
-test2
-
-\ Baden's test case
-
-: quadroot c f! b f! a f!
- f" d = sqrt(b^2-4*a*c) "
- f" (-b+d)/(2*a) " f" (-b-d)/(2*a) "
-;
-cr cr
-see quadroot
-
-: goldenratio f" max(quad root(1,-1,-1)) " ;
-cr cr
-see goldenratio
-cr cr
-goldenratio f.
-
-
-
-0 [IF]
-Output should look like:
-
-: test0
- c f@ b f@ f+ cr fe. c f@ fnegate b f@ f+ cr fe. c f@ fnegate b f@
- f+ c f@ b f@ f+ f/ cr fe. ;
-7.00000000000000E0
--1.00000000000000E0
--142.857142857143E-3
-
-
-: test1
- x f@ fabs 3.17000000000000E-5 w f@ ftanh f/ fnegate b f@ c f@ f* f+
- f+ a f! a f@ cr fe. ;
-14.4682999894333E0 ok
-
-: test2
- c f@ noop 3.75000000000000E0 f** cr fe. b f@ f^4 cr fe. ;
-181.019335983756E0
-81.0000000000000E0 ok
-
-: QUADROOT C F! B F! A F! B F@ F^2 flit 4.00000 A F@
- C F@ F* F* F- FSQRT D F! B F@ FNEGATE D
- F@ F+ flit 2.00000 A F@ F* F/ B F@ FNEGATE
- D F@ F- flit 2.00000 A F@ F* F/ ;
-
-
-: GOLDENRATIO flit 1.00000 flit -1.00000 flit -1.00000
- QUADROOT FMAX ;
-
-1.61803 ok
-
-with more or fewer places.
-
-[THEN]
-
-
-
-
diff --git a/doc/releases.html b/doc/releases.html
new file mode 100644
index 000000000000..e5291c3e54d8
--- /dev/null
+++ b/doc/releases.html
@@ -0,0 +1,1267 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>ficl release history</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+ficl release history
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4031'>
+Version 4.0.31
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+
+<li>
+First official release of new engine as Ficl 4! Hooray!
+
+<li>
+<code>ficlDictionarySee()</code> now takes a <code>ficlCallback</code>,
+so it knows where to print to. This is because <b>ficlWin</b> only
+sets a per-VM callback, which <i>should</i> work.
+
+<li>
+<code>ficlSystemCreate()</code> now passes in the system correctly
+into the dictionaries it creates, which lets dictionaries know what
+system they're a part of.
+
+<li>
+ficlCompatibility: Forgot to add the <code>errorTextOut</code> to the
+<code>ficl_system</code> structure (though I'd remembered to add it to
+the <code>ficl_vm</code> structure). This caused the <code>ficl_system</code>
+members after <code>textOut</code> to not line up with their equivalent
+<code>ficlSystem</code> members, which did bad things. (The bad thing
+in particular was calling <code>ficlDictionaryResetSearchOrder()</code>
+resulted in diddling the <code>vm->link</code> member, which strangely
+enough resulted in double-freeing the stacks.)
+
+<li>
+Added <code>ficlStackWalk()</code>, which walks a stack from top
+to bottom and calls your specified callback with each successive
+element. Cleaned up stack-printing functions as a result.
+
+<li>
+Changed <code>MULTICALL</code> so you can explicitly specify the vtable.
+
+<li>
+Changed XClasses so it explicitly specifies the vtable for
+non-virtual classes. This means you can now call a virtual
+method when you've <code>SUPER</code>ed an object and you'll
+get the method you wanted.
+
+<li>
+XClasses improvement: when removing a thunked method, remove
+the thunk variable too. Added <code>xClass.removeMember()</code>
+to support this.
+
+<li>
+XClasses now generates runtime stack-check code (<code>_DEBUG</code>
+only) for functions thunked from C to Ficl.
+
+<li>
+<code>FICL_WANT_PLATFORM</code> is now <code>0</code> by default.
+It is now set to <code>1</code> in the appropriate <code>ficlplatform/*.h</code>.
+
+<li>
+<code>softcore/win32.fr ENVIRONMENT? COMPARE<code> needed to be case-insensitive.
+
+<li>
+Whoops! Setting <code>FICL_PLATFORM_2INTEGER</code> to 0
+didn't compile. It now does, and works fine, as proved by
+the <code>ansi</code> platform.
+
+<li>
+Another whoops: contrib/xclasses/xclasses.py assumed that <code>"</code> (a prefix
+version of <code>S"</code>) defined. Switched to <code>S"</code>, which is safer.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4030'>
+Version 4.0.30
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+
+<li>
+Cleaned up some <code>FICL_</code> definitions. Now all <code>FICL_HAVE_*</code> constants
+(and some other odds and ends) have been moved to <code>FICL_PLATFORM_</code>.
+
+<li>
+Whoops! Setting <code>FICL_PLATFORM_2INTEGER</code> to 0 didn't
+compile. It now does, and works fine, as proved by
+the <code>"ansi"</code> platform.
+
+<li>
+Another whoops: <code>contrib/xclasses/xclasses.py</code> assumed that <code>"</code> (a prefix
+version of <code>S"</code>) defined. Switched to <code>S"</code>, which is safer.
+
+<li>
+Added <code>ficlDictionarySetConstantString()</code>. 'Cause I needed it for:
+
+<li>
+Removed the <code>"WIN32"</code> <code>ENVIRONMENT?</code> setting, and added <code>"FICL_PLATFORM_OS"</code>
+and <code>"FICL_PLATFORM_ARCHITECTURE"</code> in its place. These are both <i>strings</i>.
+Updated <code>softcore/win32.fr</code> to match.
+
+<li>
+Compatibility: improved <code>ficlTextOut()</code> behavior. It makes life slightly
+less convenient for some users, but should be an improvement overall.
+The change: <code>ficlTextOut()</code> is now a compatibility-layer function that
+calls straight through to <code>vmTextOut()</code>. Lots of old code calls <code>ficlTextOut()</code>
+(naughty!). It's now explicit that you must set the <code>textOut</code> function
+by hand if you use a custom one... which is a good habit to get in to anyway.
+
+<li>
+Improved the documentation regarding upgrading, <code>ficllocals.h</code>, and compile-time
+constants.
+
+<li>
+Fixed <code>doc/source/generate.py</code> so it gracefully fails to copy over read-only
+files.
+
+<li>
+Got rid of every <code>#ifdef</code> in the sources. We now consistently use <code>#if defined()</code>
+everywhere. Similarly, got rid of all platform-switched <code>#if</code> code (except for the
+compatibility layer, sigh).
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4029'>
+Version 4.0.29
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+
+<li>
+Documentation totally reworked and updated.
+
+<li>
+<code>oldnames</code> renamed to <code>compatibility</code>.
+And improved, so that now Ficl 4 is basically a drop-in
+replacement for Ficl 3.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4028'>
+Version 4.0.28
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+
+<li>
+Did backwards-compatibility testing. Ficl now drops in, more or less,
+with all the old Ficl-3.03-using projects I had handy.
+
+<li>
+Got Ficl compiling and running fine on Linux.
+
+<li>
+Weaned LZ77 code from needing htonl()/ntohl().
+
+<li>
+Moved all the primitives defined in "testmain.c" to their own file,
+"extras.c", and gave it its own global entry point.
+
+<li>
+Renamed "testmain.c" to just plain "main.c".
+
+<li>
+Renamed "softwords" directory to "softcore". More symmetrical.
+
+<li>
+Renamed "softcore\softcore.bat" to "make.bat". Added support for "CLEAN".
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4027'>
+Version 4.0.27
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+
+<li>
+Added runtime jump-to-jump peephole optimization in the new
+switch-threaded VM.
+
+<li>
+Fixed <code>INCLUDE-FILE</code> so it rethrows an exception in the
+subordinate evaluation.
+
+<li>
+Added a separate <code>errorOut</code> function to
+<code>ficlCallback()</code>,
+so under Windows you can have a jolly popup window to
+rub your nose in your failings.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4026'>
+Version 4.0.26
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+
+<li>
+Namespace policing complete. There are now <i>no</i> external symbols
+which do not start with the word <code>ficl</code>.
+
+<li>
+Removed <code>ficlVmExec()</code>, renamed <code>ficlVmExecC()</code> to
+<code>ficlVmExecuteString()</code>, changed it to take a <code>ficlString()</code>.
+This is deliberate subterfuge on my part; I suspect most
+people who currently call <code>ficlVmExec() / ficlVmExecC()</code>
+should be calling <code>ficlVmEvaluate()</code>.
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4025'>
+Version 4.0.25
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+
+<li>
+First pass at support for "oldnames", and namespace policing.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version4023'>
+Version 4.0.23
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+First alpha release of Ficl 4.0 rewrite. Coded, for better
+or for worse, by Larry Hastings.
+Ficl is <i>smaller</i>, <i>faster</i>, <i>more powerful</i>,
+and <i>easier to use</i> than ever before. (Or your money back!)
+<ul>
+<li>
+Rewrote Ficl's virtual machine; Ficl now runs nearly 3x faster out-of-the-box.
+The new virtual machine is of the "big switch statement" variety.
+
+<li>
+Renamed most (probably all) external Ficl functions and data structures.
+They now make sense and are (gasp!) consistent.
+
+<li>
+Retooled double-cell number support to take advantage of platforms
+which natively support double-cell-sized integers. (Like most modern
+32-bit platforms.)
+
+<li>
+Locals and VALUEs are now totally orthogonal; they can be single- or
+double-cell, and use the float or data stack. TO automatically supports all variants.
+
+<li>
+The "softcore" words can now be stored compressed, with a (current)
+savings of 11k. Decompression is nigh-instantaneous. You can choose
+whether or not you want softcore stored compressed at compile-time.
+
+<li>
+Reworked Win32 build process. Ficl now builds out-of-the-box on Win32
+as a static library, as a DLL, and as a command-line program,
+in each of the six possible runtime variants (Debug,Release x Singlethreaded,
+Multithreaded,Multithreaded DLL).
+
+<li>
+There's very likely other wonderful things that I've long forgotten
+about. If you notice them, feel free to remind me :)
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version303'>
+Version 3.03
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+<li>
+Bugfix for floating-point numbers. Floats in compiled code were simply broken.
+
+<li>
+New words: <code>random</code> and <code>seed-random</code>
+
+<li>
+Bugfix: <code>included</code> never closed its file.
+
+<li>
+Bugfix: <code>include</code> was not <code>IMMEDIATE</code>.
+
+<li>
+Un-hid the OO words <code>parse-method</code>, <code>lookup-method</code>, and <code>find-method-xt</code>, as there are perfectly legitimate reasons why you might want to use them.
+
+<li>
+Changed the prefix version of <code>.(</code> to be <code>IMMEDIATE</code> too.
+
+<li>
+Fixed comment in Python softcore builder.
+
+<li>
+Put the <b>doc</b> directory back in to the distribution. (It was missing from 3.02... where'd it go?)
+
+</ul>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version302'>
+Version 3.02
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+<li>
+Added support for <code>nEnvCells</code> (number of environment cells) to <code>FICL_SYSTEM_INFO</code>.
+
+<li>
+Consolidated <code>context</code> and <code>pExtend</code> pointers of <code>FICL_SYSTEM</code>&#151;VM's <code>pExtend</code> pointer is initialized from the copy in <code>FICL_SYSTEM</code> upon VM creation.
+
+<li>
+Added <code>ficl-robust</code> environment variable.
+
+<li>
+Added <code>FW_ISOBJECT</code> word type.
+
+<li>
+Bugfix: <code>environment?</code> was ignoring the length of the supplied string.
+
+<li>
+Portability cleanup in fileaccess.c.
+
+<li>
+Bugfix in <code>ficlParsePrefix</code>: if the prefix dictionary isn't in the wordlist, the word being examined cannot be a prefix, so return failure.
+
+<li>
+<code>SEE</code> improvements: <code>SEE</code> (and consequently <code>DEBUG</code>) have improved source listings with instruction offsets.
+
+<li>
+It's turned off with the preprocessor, but we have the beginnings of a switch-threaded implementation of the inner loop.
+
+<li>
+Added <code>objectify</code> and <code>?object</code> for use by OO infrastructure.
+
+<li>
+<code>my=[</code> detects object members (using <code>?object</code>) and assumes all other members leave class unchanged.
+
+<li>
+Removed <code>MEMORY-EXT</code> environment variable (there is no such wordset).
+
+<li>
+Ficlwin changes:
+<ul>
+<li>
+Ficlwin character handling is more robust
+
+<li>
+Ficlwin uses multi-system constructs (see ficlthread.c)
+
+</ul>
+
+<li>
+Documentation changes:
+<ul>
+<li>
+Corrected various bugs in docs.
+
+<li>
+Added ficl-ized version of JV Noble's Forth Primer
+
+<li>
+Ficl OO tutorial expanded and revised. Thanks to David McNab for his demo and suggestions.
+
+</ul>
+
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version301'>
+Version 3.01
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+<li>
+Major contributionss by Larry Hastings (larry@hastings.org):
+<ul>
+<li>
+FILE wordset (fileaccess.c)
+
+<li>
+ficlEvaluate wrapper for ficlExec
+
+<li>
+ficlInitSystemEx makes it possible to bind selectable properties to VMs at create time
+
+<li>
+Python version of softcore builder ficl/softwords/softcore.py
+
+</ul>
+
+<li>
+Environment contains ficl-version (double)
+
+<li>
+?number handles trailing decimal point per DOUBLE wordset spec
+
+<li>
+Fixed broken .env (thanks to Leonid Rosin for spotting this goof)
+
+<li>
+Fixed broken floating point words that depended on evaluation order of stack pops.
+
+<li>
+env-constant
+
+<li>
+env-2constant
+
+<li>
+dictHashSummary is now commented out unless FICL_WANT_FLOAT (thanks to Leonid Rosin again)
+
+<li>
+Thanks to David McNab for pointing out that .( should be IMMEDIATE. Now it is.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version300a'>
+Version 3.00a
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+<li>
+Fixed broken oo.fr by commenting out vcall stuff using FICL_WANT_VCALL. Vcall is still broken.
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version300'>
+Version 3.00
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+<li>
+Added pSys parameter to most ficlXXXX functions for multiple system support. Affected functions:
+<ul>
+<li>dictLookupLoc renamed to ficlLookupLoc after addition of pSys param
+<li>ficlInitSystem returns a FICL_SYSTEM*
+<li>ficlTermSystem
+<li>ficlNewVM
+<li>ficlLookup
+<li>ficlGetDict
+<li>ficlGetEnv
+<li>ficlSetEnv
+<li>ficlSetEnvD
+<li>ficlGetLoc
+<li>ficlBuild
+</ul>
+
+
+<li>Fixed off-by-one bug in ficlParsePrefix
+<li>Ficl parse-steps now work correctly - mods to interpret()
+<li>Made tools.c:isAFiclWord more selective
+<li>Tweaked makefiles and code to make gcc happy under linux
+<li>Vetted all instances of LVALUEtoCELL to make sure they're working on CELL sized operands
+(for 64 bit compatibility)
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version206'>
+Version 2.06
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<ul>
+<li>Debugger changes:
+<ul>
+<li>New debugger command "x" to execute the rest of the command line as ficl
+<li>New debugger command "l" lists the source of the innermost word being debugged
+<li>If you attempt to debug a primitive, it gets executed rather than doing nothing
+<li><code>R.S</code> displays the stack contents symbolically
+<li>Debugger now operates correctly under ficlwin, although ficlwin's key handling leaves a lot to be desired.
+<li><code>SEE</code> listing enhanced for use with the debugger
+</ul>
+<li>Added Guy Carver's changes to oo.fr for VTABLE support
+<li><code>float.c</code> words f&gt; and &gt;f to move floats to and from the param stack, analogous to &gt;r and r&gt;
+<li><code>LOOKUP</code> - Surrogate precompiled parse step for ficlParseWord (this step is hard
+ coded in <code>INTERPRET</code>)
+<li>License text at top of source files changed from LGPL to BSD by request
+<li>Win32 console version now handles exceptions more gracefully rather than crashing - uses win32
+structured exception handling.
+<li>Fixed BASE bug from 2.05 (was returning the value rather than the address)
+<li>Fixed ALLOT bug - feeds address units to dictCheck, which expects Cells. Changed dictCheck
+to expect AU.
+<li>Float stack display word renamed to f.s from .f to be consistent with r.s and .s
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version205'>
+Version 2.05
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+<h3>General</h3>
+
+<ul>
+<li>HTML documentation extensively revised
+<li>Incorporated Alpha (64 bit) patches from the freeBSD team.
+<li>Split SEARCH and SEARCH EXT words from words.c to search.c
+<li><a href="ficl_loc.html">2LOCALS</a> defined in <a href="ficl_loc.html#jhlocal">Johns Hopkins local syntax</a> now lose the first '2:' in their names.
+<li>Simple step <a href="ficl_debug.html">debugger</a> (see tools.c)
+<li>The text interpreter is now extensible - this is accomplished through the use
+of <code>ficlAddParseStep()</code>. <code>FICL_MAX_PARSE_STEPS</code> limits the number of parse steps
+(default: 8). You can write a precompiled parse step (see <code>ficlParseNumber</code>) and
+append it to the chain, or you can write one in ficl and use <code>ADD-PARSE-STEP</code>
+to append it. Default parse steps are initialized in <code>ficlInitSystem</code>. You can list
+the parse steps with <code>parse-order ( -- )</code>.
+<li>There is now a FICL_SYSTEM structure. This is a transitional release - version 3.0
+will alter several API prototypes to take this as a parameter, allowing multiple
+systems per process (and therefore multiple dictionaries). For those who use ficl
+under a virtual memory O/S like Linux or Win NT, you can just create multiple ficl
+processes (not threads) instead and save youself the wait.
+<li>Fixes for improved command line operation in testmain.c (Larry Hastings)
+<li>Numerous extensions to OO facility, including a new allot methods, ability
+to catch method invocations (thanks to Daniel Sobral again)
+<li>Incorporated Alpha (64 bit) patches contributed by Daniel Sobral and the freeBSD team
+Ficl is now 64 bit friendly! UNS32 is now FICL_UNS.
+<li>Split SEARCH and SEARCH EXT words from words.c to search.c
+<li>ABORT" now complies with the ANS (-2 THROWs)
+<li>Floating point support contributed by Guy Carver (Enable FICL_WANT_FLOAT in sysdep.h).
+<li>Win32 vtable model for objects (Guy Carver)
+<li>Win32 dll load/call suport (Larry Hastings)
+<li>Prefix support (Larry Hastings) (prefix.c prefix.fr FICL_EXTENDED_PREFIX) makes it
+easy to extend the parser to recignize prefixes like 0x and act on them. Use show-prefixes
+to see what's defined.
+<li>Cleaned up initialization sequence so that it's all in ficlInitSystem, and so that
+a VM can be created successfully before the dictionary is created
+</ul>
+
+<h3>
+Bug fixes</h3>
+
+<ul>
+<li>
+<a href="http://www.taygeta.com/forth/dpans9.htm#9.6.2.0680">ABORT"</a>
+now works correctly (I promise!)
+
+<li>
+<a href="http://www.taygeta.com/forth/dpans6.htm#6.2.2125">REFILL</a> works
+better
+
+<li>
+<a href="http://www.taygeta.com/forth/dpans6.htm#6.1.0710">ALLOT</a>'s
+use of dictCheck corrected (finally)
+</ul>
+
+<h3>
+New words</h3>
+
+<ul>
+<li>
+<a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0415">2r@</a> <a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0410">2r></a> <a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0340">2>r</a>
+(CORE EXT)
+
+<li>
+<a href="http://www.taygeta.com/forth/dpans8.htm#8.6.1.0440">2VARIABLE</a>
+(DOUBLE)
+
+<li>
+<a href="http://www.taygeta.com/forth/dpans16.htm#16.6.2.1985">ORDER</a>
+now lists wordlists by name
+
+<li>
+<a href="http://www.taygeta.com/forth/dpans15.htm#15.6.1.0220">.S</a> now
+displays all stack entries on one line, like a stack comment
+
+<li>
+<a href="ficl.html#wid-get-name"><tt>wid-get-name</tt>&nbsp;</a>&nbsp;
+given a wid, returns the address and count of its name. If no name, count
+is 0
+
+<li>
+<tt><a href="ficl.html#wid-set-name">wid-set-name</a></tt>&nbsp;
+set optional wid name pointer to the \0 terminated string address specified.
+
+<li>
+<tt><a href="ficl.html#ficlwordlist">ficl-named-wordlist</a></tt> creates
+a ficl-wordlist and names it. This is now used in <tt>vocabulary</tt> and
+<tt><a href="ficl.html#ficlvocabulary">ficl-vocabulary</a></tt>&nbsp;
+
+<li>
+<tt><a href="ficl.html#last-word">last-word</a></tt>&nbsp; returns the
+xt of the word being defined or most recently defined.
+
+<li>
+<tt><a href="ficl.html#qfetch">q@</a></tt> and <tt><a href="ficl.html#qbang">q!</a></tt>
+operate on quadbyte quantities for 64 bit friendliness
+</ul>
+
+<h3>
+New OO stuff</h3>
+
+<ul>
+<li>
+<tt>ALLOT (class method)</tt>
+
+<li>
+<tt>ALLOT-ARRAY (class method)</tt>
+
+<li>
+<tt>METHOD</tt> define method names globally
+
+<li>
+<tt>MY=></tt> early bind a method call to "this" class
+
+<li>
+<tt>MY=[ ]</tt> early bind a string of method calls to "this" class and
+obj members
+
+<li>
+<tt>C-></tt> late bind method invocation with CATCH
+
+<li>
+Metaclass method <tt>resume-class</tt> and instance word <tt>suspend-class</tt>
+create mutually referring classes. Example in string.fr
+
+<li>
+Early binding words are now in the instance-vars wordlist, not visible
+unless defining a class.
+
+<li>Support for refs to classes with VTABLE methods (contributed by Guy Carver). Guy writes:
+<p>
+My next favorite change is a set of VCALL words that allow me
+to call C++ class virtual methods from my forth classes. This
+is accomplished by interfacing with the VTABLE of the class. The
+class instance currently must be created on the C++ side.
+C++ places methods in the VTABLE in order of declaration in the
+header file. To use this in FICL one only needs to ensure
+that the VCALL: declerations occur in the same order. I use this
+quite a bit to interface with the C++ classes. When I need access
+to a method I make sure it is virtual (Even if it ultimately will
+not be). I use Visual C++ 6.0 and have not tested this under
+any other compiler but I believe VTABLE implementation is standard.
+</p><p>
+Here is an example of how to use VCALL:
+</p>
+<b>C++ class declaration</b>
+<pre>
+class myclass
+{
+public:
+ myclass();
+ virtual ~myclass();
+ virtual void Test( int iParam1 );
+ virtual int Test( int iParam1, char cParam2 );
+ virtual float Test();
+};
+</pre>
+<b>ficl class declaration</b>
+<pre>
+object subclass myfclass hasvtable \ hasvtable adds 4 to the offset to
+ \ accommodate for the VTABLE pointer.
+0 VCALL: Destructor() \ VCALL: ( ParamCount -<MethodName>- )
+1 VCALL: Test(int) \ Test takes 1 int parameter.
+2 VCALLR: iTest(int,char) \ iTest takes 2 parameters and returns an int.
+0 VCALLF: fTest() \ fTest takes no parameters and returns a float.
+end-class
+
+MyCAddress \ Primitive to return a pointer to a "myclass" instance.
+myfclass -> ref dude \ This makes the MyCAddress pointer a myfclass
+ \ instance with the name "dude".
+1234 dude -> Test(int) \ Calls the virtual method Test.
+1234 1 dude -> iTest(int,char) . \ Calls iTest and emits the returned int.
+dude -> fTest() f. \ Calls fTest and emits the returned float.
+</pre>
+
+</ul>
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version204'>
+Version 2.04
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<h3>ficlwin</h3>
+
+<ul>
+<li>
+Catches exceptions thrown by VM in ficlThread (0 @ for example) rather
+than passing them off to the OS.&nbsp;
+</ul>
+
+<h3>
+ficl bugs vanquished</h3>
+
+<ul>
+<li>
+Fixed leading delimiter bugs in s" ." .( and ( (reported by Reuben Thomas)
+
+<li>
+Makefile tabs restored (thanks to Michael Somos)
+
+<li>
+ABORT" now throws -2 per the DPANS (thanks to Daniel Sobral for sharp eyes
+again)&nbsp;
+
+<li>
+ficlExec does not print the prompt string unless (source-id == 0)
+
+<li>
+Various fixes contributed by the FreeBSD team.
+</ul>
+
+<h3>
+ficl enhancements</h3>
+
+<ul>
+<li>
+Words.c: modified ficlCatch to use vmExecute and vmInnerLoop (request of
+Daniel Sobral) Added vmPop and vmPush functions (by request of Lars Krueger
+) in vm.c These are shortcuts to the param stack. (Use LVALUEtoCELL to
+get things into CELL form)&nbsp;
+
+<li>
+Added function vmGetStringEx with a flag to specify whether or not to skip
+lead delimiters
+
+<li>
+Added non-std word: number?
+
+<li>
+Added CORE EXT word AGAIN (by request of Reuben Thomas)&nbsp;
+
+<li>
+Added double cell local (2local) support
+
+<li>
+Augmented Johns Hopkins local syntax so that locals whose names begin with
+char 2 are treated as 2locals (OK - it's goofy, but handy for OOP)
+
+<li>
+C-string class revised and enhanced - now dynamically sized
+
+<li>
+C-hashstring class derived from c-string computes hashcode too.
+</ul>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version203'>
+Version 2.03
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+This is the first version of Ficl that includes contributed code. Thanks
+especially to Daniel Sobral, Michael Gauland for contributions and bug
+finding.
+<p>
+New words:
+<ul>
+<li>
+<tt><a href="#clock">clock</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FICL)</tt>
+
+<li>
+<tt><a href="#clockspersec">clocks/sec</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FICL)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans8.htm#8.6.1.1230">dnegate</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(DOUBLE)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans10.htm#10.6.2.1905">ms</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FACILITY EXT - replaces MSEC <i>ficlWin only</i>)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans9.htm#9.6.1.2275">throw</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(EXCEPTION)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans9.htm#9.6.1.0875">catch</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(EXCEPTION)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.0707">allocate</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(MEMORY)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.1605">free</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(MEMORY)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.2145">resize</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(MEMORY)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans6.htm#6.2.2440">within</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(CORE EXT)</tt>
+
+<li>
+<tt><a href="#alloc">alloc</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(class method)</tt>
+
+<li>
+<tt><a href="#allocarray">alloc-array</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(class method)</tt>
+
+<li>
+<tt><a href="#oofree">free</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(class method)</tt>
+</ul>
+
+Bugs Fixed:
+<ul>
+<li>
+Bug fix in isNumber(): used to treat chars between 'Z' and 'a' as valid
+in base 10... (harmless, but weird)
+
+<li>
+ficlExec pushes the <i>ip</i> and <tt>interpret</tt>s at the right times
+so that nested calls to ficlExec behave the way you'd expect them to.
+
+<li>
+<tt>evaluate</tt> respects count parameter, and also passes exceptional
+return conditions back out to the calling instance of ficlExec.
+
+<li>
+VM_QUIT now clears the locals dictionary in ficlExec.
+</ul>
+Ficlwin Enhancements&nbsp;
+<ul>
+<li>
+File Menu: recent file list and Open now load files.
+
+<li>
+Text ouput function is now faster through use of string caching. Cache
+flushes at the end of each line and each time ficlExec returns.
+
+<li>
+Edit/paste now behaves more reasonably for text. File/open loads the specified
+file.
+
+<li>
+Registry entries specify dictionary and stack sizes, default window placement,
+and whether or not to create a splitter for multiple VMs. See HKEY_CURRENT_USER/Software/CodeLab/ficlwin/Settings
+</ul>
+Ficl Enhancements&nbsp;
+<ul>
+<li>
+This version includes changes to make it <b>64 bit friendly</b>. This unfortunately
+meant that I had to tweak some core data types and structures. I've tried
+to make this transparent to 32 bit code, but a couple of things got renamed.
+INT64 is now DPINT. UNS64 is now DPUNS. FICL_INT and FICL_UNS are synonyms
+for INT32 and UNS32 in 32 bit versions, but a are obsolescent. Please use
+the new data types instead. Typed stack operations on INT32 and UNS32 have
+been renamed because they operate on CELL scalar types, which are 64 bits
+wide on 64 bit systems. Added BITS_PER_CELL, which has legal values of
+32 or 64. Default is 32.
+
+<li>
+ficl.c: Added ficlExecXT() - executes an xt completely before returning,
+passing back any exception codes generated in the process. Normal exit
+code is VM_INNEREXIT.
+
+<li>
+ficl.c: Added ficlExecC() to operate on counted strings as opposed to zero
+terminated ones.
+
+<li>
+ficlExec pushes ip and executes interpret at the right times so that nested
+calls to ficlExec behave the way you'd expect them to.
+
+<li>
+ficlSetStackSize() allows specification of stack size at run-time (affects
+subsequent invocations of ficlNewVM()).
+
+<li>
+vm.c: vmThrow() checks for (pVM->pState != NULL) before longjmping it.
+vmCreate nulls this pointer initially.&nbsp;
+
+<li>
+EXCEPTION wordset contributed by Daniel Sobral of FreeBSD
+
+<li>
+MEMORY-ALLOC wordset contributed by Daniel Sobral, too. Added class methods
+<tt>alloc</tt>
+and <tt>alloc-array</tt> in softwords/oo.fr to allocate objects from the
+heap.
+
+<li>
+Control structure match check upgraded (thanks to Daniel Sobral for this
+suggestion). Control structure mismatches are now errors, not warnings,
+since the check accepts all syntactally legal constructs.
+
+<li>
+Added vmInnerLoop() to vm.h. This function/macro factors the inner&nbsp;
+interpreter out of ficlExec so it can be used in other places. Function/macro
+behavior is conditioned on INLINE_INNER_LOOP in sysdep.h. Default: 1 unless
+_DEBUG is set. In part, this is because VC++ 5 goes apoplectic when trying
+to compile it as a function. See&nbsp;
+
+<br>comments in vm.c
+<li>
+EVALUATE respects the count parameter, and also passes exceptional return
+conditions back out to the calling instance of ficlExec.
+
+<li>
+VM_QUIT clears locals dictionary in ficlExec()
+
+<li>
+Added Michael Gauland's ficlLongMul and ficlLongDiv and support routines
+to math64.c and .h. These routines are coded in C, and are compiled only
+if PORTABLE_LONGMULDIV == 1 (default is 0).
+
+<li>
+Added definition of ficlRealloc to sysdep.c (needed for memory allocation
+wordset). If your target OS supports realloc(), you'll probably want to
+redefine ficlRealloc in those terms. The default version does ficlFree
+followed by ficlMalloc.
+
+<li>
+testmain.c: Changed gets() in testmain to fgets() to appease the security
+gods.
+
+<li>
+testmain: <tt>msec</tt> renamed to <tt><a href="#ficlms">ms</a></tt> in
+line with the ANS
+
+<li>
+softcore.pl now removes comments &amp; spaces at the start and end of lines.
+As a result: sizeof (softWords) == 7663 bytes (used to be 20000)&nbsp;
+and consumes 11384 bytes of dictionary when compiled
+
+<li>
+Deleted license paste-o in readme.txt (oops).
+</ul>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version202'>
+Version 2.02
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+New words:
+<ul>
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans6.htm#6.2.1850">marker</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(CORE EXT)</tt>
+
+<li>
+<tt><a href="http://www.taygeta.com/forth/dpans15.htm#15.6.2.1580">forget</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(TOOLS EXT)</tt>
+
+<li>
+<tt><a href="#ficlforgetwid">forget-wid</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FICL)</tt>
+
+<li>
+<tt><a href="#ficlwordlist">ficl-wordlist</a>&nbsp;&nbsp;&nbsp;&nbsp; (FICL)</tt>
+
+<li>
+<tt><a href="#ficlvocabulary">ficl-vocabulary</a>&nbsp;&nbsp; (FICL)</tt>
+
+<li>
+<tt><a href="#ficlhide">hide</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FICL)</tt>
+
+<li>
+<tt><a href="#ficlhidden">hidden</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
+(FICL)</tt>
+
+<li>
+<a href="#jhlocal">Johns Hopkins local variable syntax</a> (as best I can
+determine)
+</ul>
+Bugs Fixed&nbsp;
+<ul>
+<li>
+<tt>forget</tt> now adjusts the dictionary pointer to remove the name of
+the word being forgotten (name chars come before the word header in ficl's
+dictionary)
+
+<li>
+<tt>:noname</tt> used to push the colon control marker and its execution
+token in the wrong order
+
+<li>
+<tt>source-id</tt> now behaves correctly when loading a file.
+
+<li>
+<tt>refill</tt> returns zero at EOF (Win32 load). Win32 <tt><a href="#ficlload">load</a></tt>
+command continues to be misnamed. Really ought to be called <tt>included</tt>,
+but does not exactly conform to that spec either (because <tt>included</tt>
+expects a string signature on the stack, while Ficl's <tt><a href="#ficlload">load</a></tt>
+expects a filename upon invocation). The "real" <tt>LOAD</tt> is a <tt>BLOCK</tt>
+word.
+</ul>
+Enhancements (IMHO)&nbsp;
+<ul>
+<li>
+dictUnsmudge no longer links anonymous definitions into the dictionary
+
+<li>
+<tt>oop</tt> is no longer the default compile wordlist at startup, nor
+is it in the search order. Execute <b><tt>also oop definitions</tt></b>
+to use Ficl OOP.
+
+<li>
+Revised oo.fr extensively to make more use of early binding
+
+<li>
+Added <tt>meta</tt> - a constant that pushes the address of metaclass.
+See oo.fr for examples of use.
+
+<li>
+Added classes: <tt>c-ptr&nbsp; c-bytePtr&nbsp; c-2bytePtr&nbsp; c-cellPtr
+</tt>These
+classes model pointers to non-object data, but each knows the size of its
+referent.
+</ul>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version201'>
+Version 2.01
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+<li>
+Bug fix: <tt>(local)</tt> used to leave a value on the stack between the
+first and last locals declared. This value is now stored in a static.
+
+<li>
+Added new local syntax with parameter re-ordering. <a href="#newlocal">See
+description below</a>. (No longer compiled in version 2.02, in favor of
+the Johns Hopkins syntax)
+</ul>
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='Version20'>
+Version 2.0
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<ul>
+<li>
+New ANS Forth words: <tt>TOOLS</tt> and part of <tt>TOOLS EXT, SEARCH</tt>
+and <tt>SEARCH EXT, LOCALS</tt> and <tt>LOCALS EXT</tt> word sets, additional
+words from <tt>CORE EXT, DOUBLE</tt>, and <tt>STRING</tt>. (See the function
+ficlCompileCore in words.c for an alphabetical list by word set).
+
+<li>
+Simple <tt>USER</tt> variable support - a user variable is a virtual machine
+instance variable. User variables behave as <tt>VARIABLE</tt>s in all other
+respects.
+
+<li>
+Object oriented syntax extensions (see below)
+
+<li>
+Optional stack underflow and overflow checking in many CORE words (enabled
+when FICL_ROBUST >= 2)
+
+<li>
+Various bug fixes
+</ul>
+
+
+
+
+</blockquote><p></td></tr></table></body></html>
+
+
diff --git a/doc/skey.gif b/doc/skey.gif
deleted file mode 100644
index 7878ccc3431e..000000000000
--- a/doc/skey.gif
+++ /dev/null
Binary files differ
diff --git a/doc/source/api.ht b/doc/source/api.ht
new file mode 100644
index 000000000000..599ba9e16b14
--- /dev/null
+++ b/doc/source/api.ht
@@ -0,0 +1,250 @@
+<?
+ficlPageHeader("ficl api")
+
+ficlAddToNavBarAs("API")
+
+
+def entrypoint(prototype):
+ print "<p><dt>\n" + "<code>" + prototype + "</code>\n<dd>\n"
+?>
+
+
+
+<? ficlHeader1("Quick Ficl Programming Concepts Overview") ?>
+
+
+A Ficl <i>dictionary</i> is equivalent to the FORTH "dictionary"; it is where words are stored.
+A single dictionary has a single <code>HERE</code> pointer.
+<p>
+
+A Ficl <i>system information</i> structure is used to change default values used
+in initializing a Ficl <i>system</i>.
+<p>
+
+A Ficl <i>system</i> contains a single <i>dictionary</i>, and one or more <i>virtual machines</i>.
+<p>
+
+A Ficl <i>stack</i> is equivalent to a FORTH "stack". Ficl has three stacks:
+<ul>
+
+<li>
+The <i>data</i> stack, where integer arguments are stored.
+
+<li>
+The <i>return</i> stack, where locals and return addresses for subroutine returns are stored.
+
+<li>
+The <i>float</i> stack, where floating-point arguments are stored. (This stack
+is only enabled when <code>FICL_WANT_FLOAT</code> is nonzero.)
+</ul>
+
+<p>
+
+A Ficl <i>virtual machine</i> (or <i>vm</i>) represents a single running instance of the Ficl interpreter.
+All virtual machines in a single Ficl system see the same dictionary.
+<p>
+
+<? ficlHeader2("Quick Ficl Programming Tutorial") ?>
+
+Though Ficl's API offers a great deal of flexibility, most programs
+incorporating Ficl simply use it as follows:
+
+<ol>
+
+<li>
+Create a single <code>ficlSystem</code> using <code>ficlSystemCreate(NULL)</code>.
+
+<li>
+Add native functions as necessary with <code>ficlDictionarySetPrimitive()</code>.
+
+<li>
+Add constants as necessary with <code>ficlDictionarySetConstant()</code>.
+
+<li>
+Create one (or more) virtual machine(s) with <code>ficlSystemCreateVm()</code>.
+
+<li>
+Add one or more scripted functions with <code>ficlVmEvaluate()</code>.
+
+<li>
+Execute code in a Ficl virtual machine, usually with <code>ficlVmEvaluate()</code>,
+but perhaps with <code>ficlVmExecuteXT()</code>.
+
+<li>
+At shutdown, call <code>ficlSystemDestroy()</code> on the single Ficl system.
+
+</ol>
+
+
+<? ficlHeader1("Ficl Application Programming Interface") ?>
+
+The following is a partial listing of functions that interface your
+system or program to Ficl. For a complete listing, see <code>ficl.h</code>
+(which is heavily commented). For a simple example, see <code>main.c</code>.
+<p>
+
+Note that as of Ficl 4, the API is internally consistent.
+<i>Every</i> external entry point starts with the word
+<code>ficl</code>, and the word after that also corresponds
+with the first argument. For instance, a word that operates
+on a <code>ficlSystem *</code> will be called <code>ficlSystem<i>Something</i>()</code>.
+
+
+
+
+<dl>
+
+<? entrypoint("void ficlSystemInformationInitialize(ficlSystemInformation *fsi)") ?>
+
+Resets a <code>ficlSystemInformation</code> structure to all zeros.
+(Actually implemented as a macro.) Use this to initialize a <code>ficlSystemInformation</code>
+structure before initializing its members and passing it
+into <code>ficlSystemCreate()</code> (below).
+
+<? entrypoint("ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi)") ?>
+
+Initializes Ficl's shared system data structures, and creates the
+dictionary allocating the specified number of cells from the heap
+(by a call to <code>ficlMalloc()</code>). If you pass in a <code>NULL</code>
+pointer, you will recieve a <code>ficlSystem</code> using the default
+sizes for the dictionary and stacks.
+
+
+<? entrypoint("void ficlSystemDestroy(ficlSystem *system)") ?>
+
+Reclaims memory allocated for the Ficl system including all
+dictionaries and all virtual machines created by
+<code>ficlSystemCreateVm()</code>. Note that this will <i>not</i>
+automatically free memory allocated by the FORTH memory allocation
+words (<code>ALLOCATE</code> and <code>RESIZE</code>).
+
+<? entrypoint("ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary, char *name, ficlCode code, ficlUnsigned8 flags)") ?>
+
+Adds a new word to the dictionary with the given
+name, code pointer, and flags. To add
+<p>
+
+The <code>flags</code> parameter is a bitfield. The valid
+flags are:<ul>
+
+<li>
+FICL_WORD_IMMEDIATE
+<li>
+FICL_WORD_COMPILE_ONLY
+<li>
+FICL_WORD_SMUDGED
+<li>
+FICL_WORD_OBJECT
+<li>
+FICL_WORD_INSTRUCTION
+
+</ul>
+
+For more information on these flags, see <code>ficl.h</code>.
+
+
+<? entrypoint("ficlVm *ficlSystemCreateVm(ficlSystem *system)") ?>
+
+Creates a new virtual machine in the specified system.
+
+
+<? entrypoint("int ficlVmEvaluate(ficlVm *vm, char *text)") ?>
+
+ the specified C string (zero-terminated) to the given
+virtual machine for evaluation. Returns various exception codes (VM_XXXX
+in ficl.h) to indicate the reason for returning. Normal exit
+condition is VM_OUTOFTEXT, indicating that the VM consumed the string
+successfully and is back for more. Calls to <code>ficlVmEvaluate()</code>
+can be nested, and
+the function itself is re-entrant, but note that a VM is
+static, so you have to take reasonable precautions (for example, use one
+VM per thread in a multithreaded system if you want multiple threads to
+be able to execute commands).
+
+
+<? entrypoint("int ficlVmExecuteXT(ficlVm *vm, ficlWord *pFW)") ?>
+
+Same as ficlExec, but takes a pointer to a ficlWord instead of a
+string. Executes the word and returns after it has finished. If
+executing the word results in an exception, this function will
+re-throw the same code if it is nested under another ficlExec family
+function, or return the exception code directly if not. This function
+is useful if you need to execute the same word repeatedly&mdash;you
+save the dictionary search and outer interpreter overhead.
+
+<? entrypoint("void ficlFreeVM(ficlVm *vm)") ?>
+
+Removes the VM in question from the system VM list and deletes
+the memory allocated to it. This is an optional call, since
+ficlTermSystem will do this cleanup for you. This function is
+handy if you're going to do a lot of dynamic creation of VMs.
+
+<? entrypoint("ficlVm *ficlNewVM(ficlSystem *system)") ?>
+
+Create, initialize, and return a VM from the heap using
+ficlMalloc. Links the VM into the system VM list for later reclamation
+by ficlTermSystem.
+
+<? entrypoint("ficlWord *ficlSystemLookup(ficlSystem *system, char *name)") ?>
+
+Returns the address of the specified word in the main dictionary.
+If no such word is found, it returns <code>NULL</code>.
+The address is also a valid execution token, and can be used in a call to <code>ficlVmExecuteXT()</code>.
+
+<? entrypoint("ficlDictionary *ficlSystemGetDictionary(ficlSystem *system)<br>ficlDictionary *ficlVmGetDictionary(ficlVm *system)") ?>
+
+Returns a pointer to the main system dictionary.
+
+
+<? entrypoint("ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system)") ?>
+
+Returns a pointer to the environment dictionary. This dictionary
+stores information that describes this implementation as required by the
+Standard.
+
+
+
+
+<? entrypoint("ficlDictionary *ficlSystemGetLocals(ficlSystem *system)") ?>
+
+Returns a pointer to the locals dictionary. This function is
+defined only if <code>FICL_WANT_LOCALS</code> is non-zero (see <code>ficl.h</code>).
+The locals dictionary is the symbol table for
+<a href="locals.html">local variables</a>.
+
+
+</dl>
+
+
+<? ficlHeader1("Ficl Compile-Time Constants") ?>
+
+There are a lot of preprocessor constants you can set at compile-time
+to modify Ficl's runtime behavior. Some are required, such as telling
+Ficl whether or not the local platform supports double-width integers
+(<code>FICL_PLATFORM_HAS_2INTEGER</code>);
+some are optional, such as telling Ficl whether or not to use the
+extended set of "prefixes" (<code>FICL_WANT_EXTENDED_PREFIXES</code>).
+<p>
+
+The best way to find out more about these constants is to read <code>ficl.h</code>
+yourself. The settings that turn on or off Ficl modules all start with
+<code>FICL_WANT</code>. The settings relating to functionality available
+on the current platform all start with <code>FICL_PLATFORM</code>.
+<p>
+
+
+
+<? ficlHeader2("<code>ficllocal.h</code>") ?>
+
+One more note about constants. Ficl now ships with a standard place for
+you to tweak the Ficl compile-time preprocessor constants.
+It's a file called <code>ficllocal.h</code>, and we guarantee that it
+will always ship empty (or with only comments). We suggest that you
+put all your local changes there, rather than editing <code>ficl.h</code>
+or editing the makefile. That should make it much easier to integrate
+future Ficl releases into your product&mdash;all you need do is preserve
+your tweaked copy of <code>ficllocal.h</code> and replace the rest.
+
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/debugger.ht b/doc/source/debugger.ht
new file mode 100644
index 000000000000..e2187f9b2670
--- /dev/null
+++ b/doc/source/debugger.ht
@@ -0,0 +1,157 @@
+<?
+ficlPageHeader("ficl debugger")
+
+ficlAddToNavBarAs("Debugger")
+
+?>
+
+<p>Ficl includes a simple step debugger for colon definitions
+and <code>DOES></code> words.
+
+
+<? ficlHeader1("Using The Ficl Debugger") ?>
+
+
+To debug a word, set up the stack with any parameters the word requires,
+then execute:
+<pre><b>DEBUG <i>your-word-name-here</i></b></pre>
+<p>
+
+If the word is unnamed, or all you have is an execution token,
+you can instead use <code>DEBUG-XT</code></b>
+<p>
+
+The debugger invokes <tt>SEE</tt> on the word which prints a crude source
+listing. It then stops at the first instruction of the definition. There are
+six (case insensitive) commands you can use from here onwards:
+
+<dl>
+
+<dt>
+<b>I</b> (step <b>I</b>n)
+<dd>If the next instruction is a colon defintion or does> word, steps into
+that word's code. If the word is a primitive, simply executes the word.
+
+<dt>
+<b>O</b> (step <b>O</b>ver)
+<dd>
+Executes the next instruction in its entirety.
+
+<dt>
+<b>G</b> (<b>G</b>o)
+<dd>
+Run the word to completion and exit the debugger.
+
+<dt>
+<b>L</b> (<b>L</b>ist)
+<dd>
+Lists the source code of the word presently being stepped.
+
+<dt>
+<b>Q</b> (<b>Q</b>uit)
+<dd>
+Abort the word and exit the debugger, clearing the stacks.
+
+<dt>
+<b>X</b> (e<b>X</b>ecute)
+<dd>
+Interpret the remainder of the line as Ficl words. Any change
+they make to the stacks will be preserved when the debugged word
+continues execution.
+Any errors will abort the debug session and reset the VM. Usage example:
+<pre>
+X DROP 3 \ change top argument on stack to 3
+</pre>
+
+</dl>
+
+
+Any other character will prints a list of available debugger commands.
+
+
+<? ficlHeader2("The <code>ON-STEP</code> Event") ?>
+
+If there is a defined word named <code>ON-STEP</code> when the debugger starts, that
+word will be executed before every step. Its intended use is to display the stacks
+and any other VM state you find interesting. The default <code>ON-STEP</code> is:
+<p>
+
+<pre>
+: ON-STEP ." S: " .S-SIMPLE CR ;
+</pre>
+
+If you redefine <code>ON-STEP</code>, we recommend you ensure the word has no
+side-effects (for instance, adding or removing values from any stack).
+
+
+
+<? ficlHeader3("Other Useful Words For Debugging And <code>ON-STEP</code>") ?>
+
+<dl>
+
+<dt>
+<code>.ENV ( -- )</code>
+<dd>
+Prints all environment settings non-destructively.
+
+<dt>
+<code>.S ( -- )</code>
+<dd>
+Prints the parameter stack non-destructively in a verbose format.
+
+<dt>
+<code>.S-SIMPLE ( -- )</code>
+<dd>
+Prints the parameter stack non-destructively in a simple single-line format.
+
+<dt>
+<code>F.S ( -- )</code>
+<dd>
+Prints the float stack non-destructively (only available if <code>FICL_WANT_FLOAT</code> is enabled).
+
+<dt>
+<code>R.S ( -- )</code>
+<dd>
+Prints a represention of the state of the return stack non-destructively.
+
+
+
+</dl>
+
+<? ficlHeader1("Debugger Internals") ?>
+
+<p>
+The debugger words are mostly located in source file <code>tools.c</code>. There are
+supporting words (<code>DEBUG</code> and <code>ON-STEP</code>) in <code>softcore.fr</code> as well.
+There are two main words that make the debugger go: <code>debug-xt</code> and <code>step-break</code>.
+<code>debug-xt</code> takes the execution token of a word to debug (as returned by <code>'</code> for example) ,
+checks to see if it is debuggable (not a primitive), sets a breakpoint at its
+first instruction, and runs <code>see</code> on it. To set a breakpoint,
+<code>debug-xt</code>
+replaces the instruction at the breakpoint with the execution token of <code>step-break</code>, and
+stores the original instruction and its address in a static breakpoint
+record. To clear the breakpoint, <code>step-break</code> simply replaces the original
+instruction and adjusts the target virtual machine's instruction pointer
+to run it.
+
+<p>
+
+<code>step-break</code> is responsible for processing debugger commands and setting
+breakpoints at subsequent instructions.
+
+
+<? ficlHeader1("Future Enhancements") ?>
+
+<dl>
+
+<li>
+The debugger needs to exit automatically when it encounters the end of the word
+it was asked to debug. (Perhaps this could be a special kind of breakpoint?)
+
+<li>Add user-set breakpoints.
+
+<li>Add "step out" command.
+</dl>
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/dpans.ht b/doc/source/dpans.ht
new file mode 100644
index 000000000000..cfd957e269a6
--- /dev/null
+++ b/doc/source/dpans.ht
@@ -0,0 +1,589 @@
+<?
+ficlPageHeader("ficl standards compliance")
+
+ficlHeader1("ANS Required Information")
+
+ficlAddToNavBarAs("ANS")
+
+?>
+
+
+The following documentation is necessary to comply for Ficl
+to comply with the DPANS94 standard. It describes what areas
+of the standard Ficl implements, what areas it does not, and
+how it behaves in areas undefined by the standard.
+
+<blockquote>
+
+<? ficlHeader2("ANS Forth System") ?>
+
+<b>
+
+Providing names from the Core Extensions word set
+<br>
+
+Providing names from the Double-Number word set
+<br>
+
+Providing the Exception word set
+<br>
+
+Providing the Exception Extensions word set
+<br>
+
+Providing the File-Access word set
+<br>
+
+Providing the File-Access Extensions word set
+<br>
+
+Providing names from the Floating-Point word set
+<br>
+
+Providing the Locals word set
+<br>
+
+Providing the Locals Extensions word set
+<br>
+
+Providing the Memory Allocation word set
+<br>
+
+Providing the Programming-Tools word set
+<br>
+
+Providing names from the Programming-Tools Extensions word set
+<br>
+
+Providing the Search-Order word set
+<br>
+
+Providing the Search-Order Extensions word set
+<br>
+
+Providing names from the String Extensions word set
+<br>
+
+</b>
+
+
+<?
+def entry(heading):
+ print "<dt><b>\n" + heading + "\n</b><dd>\n"
+
+?>
+
+
+<? ficlHeader2("Implementation-defined Options") ?>
+
+The implementation-defined items in the following list represent
+characteristics and choices left to the discretion of the implementor,
+provided that the requirements of the Standard are met. A system shall
+document the values for, or behaviors of, each item.
+
+<dl>
+
+<? entry("aligned address requirements (3.1.3.3 Addresses)") ?>
+
+System dependent. You can change the default address alignment by
+defining <code>FICL_ALIGN</code> on your compiler's command line,
+or in <code>platform.h</code>.
+The default value is set to 2 in <code>ficl.h</code>.
+This causes dictionary entries and <code>ALIGN</code> and
+<code>ALIGNED</code> to align on 4 byte
+boundaries. To align on 2<b><sup>n</sup></b> byte boundaries,
+set <code>FICL_ALIGN</code> to <b>n</b>.
+
+
+<? entry("behavior of 6.1.1320 EMIT for non-graphic characters") ?>
+
+Depends on target system, C runtime library, and your
+implementation of <code>ficlTextOut()</code>.
+
+
+<? entry("character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT") ?>
+
+None implemented in the versions supplied in <code>primitives.c</code>.
+Because <code>ficlEvaluate()</code> is supplied a text buffer
+externally, it's up to your system to define how that buffer will
+be obtained.
+
+
+<? entry("character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750 KEY)") ?>
+
+Depends on target system and implementation of <code>ficlTextOut()</code>.
+
+
+<? entry("character-aligned address requirements (3.1.3.3 Addresses)") ?>
+
+Ficl characters are one byte each. There are no alignment requirements.
+
+
+<? entry("character-set-extensions matching characteristics (3.4.2 Finding definition names)") ?>
+
+No special processing is performed on characters beyond case-folding. Therefore,
+extended characters will not match their unaccented counterparts.
+
+
+<? entry("conditions under which control characters match a space delimiter (3.4.1.1 Delimiters)") ?>
+
+Ficl uses the Standard C function <code>isspace()</code> to distinguish space characters.
+
+
+<? entry("format of the control-flow stack (3.2.3.2 Control-flow stack)") ?>
+
+Uses the data stack.
+
+
+<? entry("conversion of digits larger than thirty-five (3.2.1.2 Digit conversion)") ?>
+
+The maximum supported value of <code>BASE</code> is 36.
+Ficl will fail via assertion in function <code>ltoa()</code> of <code>utility.c</code>
+if the base is found to be larger than 36 or smaller than 2. There will be no effect
+if <code>NDEBUG</code> is defined, however, other than possibly unexpected behavior.
+
+
+<? entry("display after input terminates in 6.1.0695 ACCEPT and 6.2.1390 EXPECT") ?>
+
+Target system dependent.
+
+
+<? entry("exception abort sequence (as in 6.1.0680 ABORT\")") ?>
+
+Calls <tt>ABORT</tt> to exit.
+
+
+<? entry("input line terminator (3.2.4.1 User input device)") ?>
+
+Target system dependent (implementation of outer loop that calls <code>ficlEvaluate()</code>).
+
+
+<? entry("maximum size of a counted string, in characters (3.1.3.4 Counted strings, 6.1.2450 WORD)") ?>
+
+Counted strings are limited to 255 characters.
+
+
+<? entry("maximum size of a parsed string (3.4.1 Parsing)") ?>
+
+Limited by available memory and the maximum unsigned value that can fit in a cell (2<sup>32</sup>-1).
+
+
+<? entry("maximum size of a definition name, in characters (3.3.1.2 Definition names)") ?>
+
+Ficl stores the first 31 characters of a definition name.
+
+
+<? entry("maximum string length for 6.1.1345 ENVIRONMENT?, in characters") ?>
+
+Same as maximum definition name length.
+
+
+<? entry("method of selecting 3.2.4.1 User input device") ?>
+
+None supported. This is up to the target system.
+
+
+<? entry("method of selecting 3.2.4.2 User output device") ?>
+
+None supported. This is up to the target system.
+
+
+<? entry("methods of dictionary compilation (3.3 The Forth dictionary)") ?>
+
+Okay, we don't know what this means. If you understand what they're asking for here,
+please call the home office.
+
+
+<? entry("number of bits in one address unit (3.1.3.3 Addresses)") ?>
+
+Target system dependent, either 32 or 64 bits.
+
+
+<? entry("number representation and arithmetic (3.2.1.1 Internal number representation)") ?>
+
+System dependent. Ficl represents a CELL internally as a union that can hold a <code>ficlInteger32</code>
+(a signed 32 bit scalar value), a <code>ficlUnsigned32</code> (32 bits unsigned),
+and an untyped pointer. No specific byte ordering is assumed.
+
+
+<? entry("ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types, 3.1.4 Cell-pair types)") ?>
+
+System dependent.
+Assuming a 32 bit implementation, range for signed single-cell values is [-2<sup>31</sup>, 2<sup>31</sup>-1].
+Range for unsigned single cell values is [0, 2<sup>32</sup>-1].
+Range for signed double-cell values is [-2<sup>63</sup>, 2<sup>63</sup>-1].
+Range for unsigned double cell values is [0, 2<sup>64</sup>-1].
+
+
+<? entry("read-only data-space regions (3.3.3 Data space)") ?>
+
+None.
+
+
+<? entry("size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient regions)") ?>
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<? entry("size of one cell in address units (3.1.3 Single-cell types)") ?>
+
+System dependent, generally 4.
+
+
+<? entry("size of one character in address units (3.1.2 Character types)") ?>
+
+System dependent, generally 1.
+
+
+<? entry("size of the keyboard terminal input buffer (3.3.3.5 Input buffers)") ?>
+
+This buffer is supplied by the host program. Ficl imposes no practical limit.
+
+
+<? entry("size of the pictured numeric output string buffer (3.3.3.6 Other transient regions)") ?>
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<? entry("size of the scratch area whose address is returned by 6.2.2000 PAD (3.3.3.6 Other transient regions)") ?>
+
+Default is 255. Depends on the setting of <code>FICL_PAD_SIZE</code> in <code>ficl.h</code>.
+
+
+<? entry("system case-sensitivity characteristics (3.4.2 Finding definition names)") ?>
+
+The Ficl dictionary is not case-sensitive.
+
+
+<? entry("system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)") ?>
+
+<code>ok&gt;</code>
+
+
+<? entry("type of division rounding (3.2.2.1 Integer division, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)") ?>
+
+Symmetric.
+
+
+<? entry("values of 6.1.2250 STATE when true") ?>
+
+1.
+
+
+<? entry("values returned after arithmetic overflow (3.2.2.2 Other integer operations)") ?>
+
+System dependent. Ficl makes no special checks for overflow.
+
+
+<? entry("whether the current definition can be found after 6.1.1250 DOES&gt; (6.1.0450 :)") ?>
+No. Definitions are unsmudged after ; only, and only then if no control structure matching problems have been detected.
+
+</dl>
+
+
+<? ficlHeader2("Ambiguous Conditions") ?>
+
+<dl>
+
+<? entry("a name is neither a valid definition name nor a valid number during text interpretation (3.4 The Forth text interpreter)") ?>
+
+Ficl calls <code>ABORT</code> then prints the name followed by <code>not found</code>.
+
+
+<? entry("a definition name exceeded the maximum length allowed (3.3.1.2 Definition names)") ?>
+
+Ficl stores the first 31 characters of the definition name, and uses all characters of the name
+in computing its hash code. The actual length of the name, up to 255 characters, is stored in
+the definition's length field.
+
+
+<? entry("addressing a region not listed in 3.3.3 Data Space") ?>
+
+No problem: all addresses in Ficl are absolute. You can reach any 32 bit address in Ficl's address space.
+
+
+<? entry("argument type incompatible with specified input parameter, e.g., passing a flag to a word expecting an n (3.1 Data types)") ?>
+
+Ficl makes no check for argument type compatibility. Effects of a mismatch vary widely depending on the specific problem and operands.
+
+
+<? entry("attempting to obtain the execution token, (e.g., with 6.1.0070 ', 6.1.1550 FIND, etc.) of a definition with undefined interpretation semantics") ?>
+
+Ficl returns a valid token, but the result of executing that token while interpreting may be undesirable.
+
+
+<? entry("dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 8.6.1.1820 M*/)") ?>
+
+Results are target procesor dependent. Generally, Ficl makes no check for divide-by-zero. The target processor will probably throw an exception.
+
+
+<? entry("insufficient data-stack space or return-stack space (stack overflow)") ?>
+
+With <code>FICL_ROBUST</code> (defined in <code>ficl.h</code>) set to a value of 2 or greater,
+most data, float, and return stack operations are checked for underflow and overflow.
+
+
+<? entry("insufficient space for loop-control parameters") ?>
+
+This is not checked, and bad things will happen.
+
+
+<? entry("insufficient space in the dictionary") ?>
+
+Ficl generates an error message if the dictionary is too full to create
+a definition header. It checks <code>ALLOT</code> as well, but it is possible
+to make an unchecked allocation request that will overflow the dictionary.
+
+
+<? entry("interpreting a word with undefined interpretation semantics") ?>
+
+Ficl protects all ANS Forth words with undefined interpretation semantics from being executed while in interpret state.
+It is possible to defeat this protection using ' (tick) and <code>EXECUTE</code> though.
+
+
+<? entry("modifying the contents of the input buffer or a string literal (3.3.3.4 Text-literal regions, 3.3.3.5 Input buffers)") ?>
+
+Varies depending on the nature of the buffer. The input buffer is supplied by ficl's host function, and may reside
+in read-only memory. If so, writing the input buffer can ganerate an exception.
+String literals are stored in the dictionary, and are writable.
+
+
+<? entry("overflow of a pictured numeric output string") ?>
+
+In the unlikely event you are able to construct a pictured numeric string of more
+than <code>FICL_PAD_LENGTH</code> characters, the system will be corrupted unpredictably.
+The buffer area that holds pictured numeric output is at the end of the virtual machine.
+Whatever is mapped after the offending VM in memory will be trashed, along with the heap
+structures that contain it.
+
+
+<? entry("parsed string overflow") ?>
+
+Ficl does not copy parsed strings unless asked to. Ordinarily, a string parsed from the input buffer during
+normal interpretation is left in-place, so there is no possibility of overflow.
+If you ask to parse a string into the dictionary, as in <code>SLITERAL</code>, you need to have enough
+room for the string, otherwise bad things may happen. This is usually not a problem.
+
+
+<? entry("producing a result out of range, e.g., multiplication (using *) results in a value too big to be represented by a single-cell integer (6.1.0090 *, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570, &gt;NUMBER, 6.1.1561 FM/MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 6.2.0970 CONVERT, 8.6.1.1820 M*/)") ?>
+
+Value will be truncated.
+
+
+<? entry("reading from an empty data stack or return stack (stack underflow)") ?>
+
+Most stack underflows are detected and prevented if <code>FICL_ROBUST</code> (defined in <code>sysdep.h</code>) is set to 2 or greater.
+Otherwise, the stack pointer and size are likely to be trashed.
+
+
+<? entry("unexpected end of input buffer, resulting in an attempt to use a zero-length string as a name") ?>
+
+Ficl returns for a new input buffer until a non-empty one is supplied.
+
+
+</dl>
+
+
+The following specific ambiguous conditions are noted in the glossary entries of the relevant words:
+
+<dl>
+
+<? entry("&gt;IN greater than size of input buffer (3.4.1 Parsing)") ?>
+
+Memory corruption will occur&mdash;the exact behavior is unpredictable
+because the input buffer is supplied by the host program's outer loop.
+
+
+<? entry("6.1.2120 RECURSE appears after 6.1.1250 DOES&gt;") ?>
+
+It finds the address of the definition before <code>DOES&gt;</code>
+
+
+<? entry("argument input source different than current input source for 6.2.2148 RESTORE-INPUT") ?>
+
+Not implemented.
+
+
+<? entry("data space containing definitions is de-allocated (3.3.3.2 Contiguous regions)") ?>
+
+This is okay until the cells are overwritten with something else.
+The dictionary maintains a hash table, and the table must be updated
+in order to de-allocate words without corruption.
+
+
+<? entry("data space read/write with incorrect alignment (3.3.3.1 Address alignment)") ?>
+
+Target processor dependent. Consequences include: none (Intel), address error exception (68K).
+
+
+<? entry("data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860 C,)") ?>
+
+See above on data space read/write alignment.
+
+<? entry("less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)") ?>
+
+If <code>FICL_ROBUST</code> is two or larger, Ficl will detect a stack underflow, report it, and execute <code>ABORT</code> to
+exit execution. Otherwise the error will not be detected, and memory corruption will occur.
+
+
+<? entry("loop-control parameters not available ( 6.1.0140 +LOOP, 6.1.1680 I, 6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)") ?>
+
+Loop initiation words are responsible for checking the stack and guaranteeing that the control parameters are pushed.
+Any underflows will be detected early if <code>FICL_ROBUST</code> is set to 2 or greater.
+Note however that Ficl only checks for return stack underflows at the end of each line of text.
+
+<? entry("most recent definition does not have a name (6.1.1710 IMMEDIATE)") ?>
+
+No problem.
+
+
+<? entry("name not defined by 6.2.2405 VALUE used by 6.2.2295 TO") ?>
+
+Ficl's version of <code>TO</code> works correctly with words defined with:
+<ul>
+
+<li> <code>VALUE</code>
+<li> <code>2VALUE</code>
+<li> <code>FVALUE</code>
+<li> <code>F2VALUE</code>
+<li> <code>CONSTANT</code>
+<li> <code>FCONSTANT</code>
+<li> <code>2CONSTANT</code>
+<li> <code>F2CONSTANT</code>
+<li> <code>VARIABLE</code>
+<li> <code>2VARIABLE</code>
+</ul>
+as well as with all "local" variables.
+
+<? entry("name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['], 6.2.2530 [COMPILE])") ?>
+
+Ficl prints an error message and executes <code>ABORT</code>
+
+<? entry("parameters are not of the same type (6.1.1240 DO, 6.2.0620 ?DO, 6.2.2440 WITHIN)") ?>
+
+Not detected. Results vary depending on the specific problem.
+
+
+<? entry("6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO") ?>
+
+The word is postponed correctly.
+
+
+<? entry("string longer than a counted string returned by 6.1.2450 WORD") ?>
+
+Ficl stores the first <code>FICL_COUNTED_STRING_MAX</code> - 1 characters in the
+destination buffer.
+(The extra character is the trailing space required by the standard. Yuck.)
+
+<? entry("u greater than or equal to the number of bits in a cell (6.1.1805 LSHIFT, 6.1.2162 RSHIFT)") ?>
+
+Depends on target process or and C runtime library implementations of the &lt;&lt; and &gt;&gt; operators
+on unsigned values. For I386, the processor appears to shift modulo the number of bits in a cell.
+
+<? entry("word not defined via 6.1.1000 CREATE (6.1.0550 &gt;BODY, 6.1.1250 DOES&gt;)") ?>
+
+<? entry("words improperly used outside 6.1.0490 &lt;# and 6.1.0040 #&gt; (6.1.0030 #, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)") ?>
+
+Undefined. <code>CREATE</code> reserves a field in words it builds for <code>DOES&gt;</code> to fill in.
+If you use <code>DOES&gt;</code> on a word not made by <code>CREATE</code> it will overwrite the first
+cell of its parameter area. That's probably not what you want. Likewise, pictured numeric words
+assume that there is a string under construction in the VM's scratch buffer. If that's not the case,
+results may be unpleasant.
+
+
+</dl>
+
+<? ficlHeader2("Locals Implementation-Defined Options") ?>
+
+<dl>
+
+<? entry("maximum number of locals in a definition (13.3.3 Processing locals, 13.6.2.1795 LOCALS|)") ?>
+
+Default is 64&mdash;unused locals are cheap. Change by redefining <code>FICL_MAX_LOCALS</code> (defined in <code>ficl.h</code>).
+
+</dl>
+
+
+<? ficlHeader2("Locals Ambiguous conditions") ?>
+
+<dl>
+
+<? entry("executing a named local while in interpretation state (13.6.1.0086 (LOCAL))") ?>
+
+Locals can be found in interpretation state while in the context of a definition under
+construction. Under these circumstances, locals behave correctly. Locals are not visible
+at all outside the scope of a definition.
+
+<? entry("name not defined by VALUE or LOCAL (13.6.1.2295 TO)") ?>
+
+See the CORE ambiguous conditions, above (no change).
+
+</dl>
+
+
+<? ficlHeader2("Programming Tools Implementation-Defined Options") ?>
+
+
+<dl>
+
+<? entry("source and format of display by 15.6.1.2194 SEE") ?>
+
+<code>SEE</code> de-compiles definitions from the dictionary. Ficl words are stored as a combination
+of things:
+<ol>
+
+<li>bytecodes (identified as "instructions"),
+<li>addresses of native Ficl functions, and
+<li>arguments to both of the above.
+
+</ol>
+Colon definitions are decompiled. Branching instructions indicate their destination,
+but target labels are not reconstructed.
+Literals and string literals are so noted, and their contents displayed.
+
+</dl>
+
+
+<? ficlHeader2("Search Order Implementation-Defined Options") ?>
+
+
+<dl>
+
+<? entry("maximum number of word lists in the search order (16.3.3 Finding definition names, 16.6.1.2197 SET-ORDER)") ?>
+
+Defaults to 16. Can be changed by redefining <code>FICL_MAX_WORDLISTS</code> (declared in <code>ficl.h</code>).
+
+
+<? entry("minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)") ?>
+
+Equivalent to <code>FORTH-WORDLIST 1 SET-ORDER</code>
+
+</dl>
+
+
+
+<? ficlHeader2("Search Order Ambiguous Conditions") ?>
+
+
+<dl>
+<? entry("changing the compilation word list (16.3.3 Finding definition names)") ?>
+
+Ficl stores a link to the current definition independently of the compile wordlist while
+it is being defined, and links it into the compile wordlist only after the definition completes
+successfully. Changing the compile wordlist mid-definition will cause the definition to link
+into the <i>new</i> compile wordlist.
+
+
+<? entry("search order empty (16.6.2.2037 PREVIOUS)") ?>
+
+Ficl prints an error message if the search order underflows, and resets the order to its default state.
+
+
+<? entry("too many word lists in search order (16.6.2.0715 ALSO)") ?>
+
+Ficl prints an error message if the search order overflows, and resets the order to its default state.
+
+</dl>
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/ficl.ht b/doc/source/ficl.ht
new file mode 100644
index 000000000000..faa49e7a7cff
--- /dev/null
+++ b/doc/source/ficl.ht
@@ -0,0 +1,1257 @@
+<!DOCTYPE html PUBLIC "-//w3c//dtd html 4.0 transitional//en">
+
+<html>
+<head>
+ <meta name="Author" content="john sadler">
+ <meta name="Description" content="Ficl - embedded scripting with object oriented programming">
+ <meta name="Keywords" content="scripting prototyping tcl OOP Forth interpreter C">
+ <link rel="SHORTCUT ICON" href="favicon.ico">
+ <title>Ficl - Embedded Scripting</title>
+</head>
+
+<body>
+
+<h1>Ficl Documentation</h1>
+
+<script language="javascript" src="ficlheader.js" type="text/javascript">
+</script>
+
+<h1><a name="whatis">What is Ficl?</a></h1>
+Ficl is a complete programming language interpreter designed to be
+embedded into other systems (including firmware based ones) as a
+command, macro, and development prototype language. Unlike other
+scripting interpreters, Ficl:
+
+<ul>
+
+<li>
+typically takes under 2 hours to port to a new system&mdash;much
+less if the target operating system is one of several already supported
+(Win32, Linux, FreeBSD, RiscOS, and more)
+
+<li>
+has a small memory footprint: a fully featured Win32 console
+version takes less than 100K of memory, and a minimal version is less
+than half that
+
+<li>
+is relatively quick thanks to its "switch-threaded" virtual
+machine design and just in time compiling
+
+<li>
+is a complete and powerful programming language
+
+<li>
+is interactive
+
+<li>
+has object oriented programming features that can be used to wrap
+data structures or classes of the host system without altering them&#151;even
+if the host is mainly written in a non-OO language
+
+</ul>
+
+<p>
+
+Ficl syntax is based on ANS Forth and the code is ANSI C. See
+below for examples of <a href="#includesficl">software and products
+that include ficl</a>. Ficl stands for "Forth inspired command language".
+
+
+<h3>Ficl Versus Other Forth Interpreters</h3>
+
+Where most Forths view themselves as the center of the system and
+expect the rest of the system to be coded in Forth, Ficl acts as a
+component of the system. It is easy to export code written in C or
+ASM to Ficl in the style of TCL, or to invoke Ficl code from a compiled
+module. This allows you to do incremental development in a way that
+combines the best features of threaded languages (rapid
+development, quick code/test/debug cycle, reasonably fast) with the best
+features of C (everyone knows it, easier to support large blocks of
+code, efficient, type checking). In addition, Ficl provides a simple
+and powerful object model that can act as an object oriented <i>adapter</i>
+for code written in C (or asm, Forth, C++...).
+
+
+<h3>Ficl Design Goals</h3>
+<ul>
+
+<li>
+Target 32- and 64-bit processors
+
+<li>
+Scripting, prototyping, and extension language for systems
+written also in C
+
+<li>
+Supportable&mdash;code is as transparent as I can make it
+
+<li>
+Interface to functions written in C
+
+<li>
+Conformant to the 1994 ANSI Standard for Forth (DPANS94)
+
+<li>
+Minimize porting effort&mdash;require an ANSI C runtime environment
+and minimal glue code
+
+<li>
+Provide object oriented extensions
+
+</ul>
+
+<hr>
+
+<h2><a name="download">Download</a></h2>
+
+<ul>
+
+<li> <b><a href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download Ficl (latest release)</a></b>
+
+</ul>
+
+<h2><a name="links">More information on Ficl and Forth</a></h2>
+
+<ul>
+
+<li>
+<a href="http://ficl.sourceforge.net">Web home of Ficl</a>
+
+<li>
+<a href="http://ficl.sourceforge.net/pdf/Forth_Primer.pdf">
+An excellent Forth Primer by Hans Bezemer
+</a>
+
+<li>
+<a href="ficlddj.pdf">
+Manuscript of Ficl article for January 1999 Dr. Dobb's Journal
+</a>
+
+<li>
+<a href="jwsforml.pdf">
+1998 FORML Conference paper&mdash;OO Programming in Ficl
+</a>
+
+<li>
+<a href="http://www.taygeta.com/forth_intro/stackflo.html">
+An Introduction to Forth using Stack Flow
+</a>
+(start here if you're new to Forth)
+
+<li>
+<a href="http://www.softsynth.com/pforth/pf_tut.htm">
+Phil Burk's Forth Tutorial
+</a>
+
+<li>
+<a href="http://www.complang.tuwien.ac.at/forth/threaded-code.html">
+Anton Ertl's description of Threaded Code
+</a>
+(Ficl now uses what he calls "switch threading")
+
+<li>
+<a href="http://ficl.sourceforge.net/dpans/dpans.htm">
+Draft Proposed American National Standard for Forth
+</a>
+(quite readable, actually)
+
+<li>
+<a href="http://www.taygeta.com/forthlit.html">
+Forth literature index on Taygeta
+</a>
+
+<li>
+<a href="http://www.forth.org">
+Forth Interest Group
+</a>
+
+</ul>
+
+<h2><a name="includesficl">Some software that uses Ficl</a></h2>
+
+<ul>
+<li>
+The <a href="http://www.freebsd.org/">FreeBSD</a> boot loader
+(Daniel Sobral, Jordan Hubbard)
+
+<li>
+<a href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">
+SwitchCore
+</a>
+Gigabit Ethernet switches (&Ouml;rjan Gustavsson )
+
+<li>
+<a href="http://debuffer.sourceforge.net/">
+Palm Pilot Debuffer
+</a>
+(Eric Sessoms) Also see ficlx, a C++ interface to ficl, on the same site
+
+<li>
+<a href="http://www.swcp.com/%7Ejchavez/osmond.html">
+Osmond PC Board Layout tool
+</a>
+
+<li>
+<a href="http://www.netcomsystems.com">
+NetCom Systems
+</a>
+ML7710
+
+<li>
+<a href="http://www.parview.com/ds/homepage.html">
+ParView
+</a>
+GPS system
+
+<li>
+<a href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">
+PowerPlant Software
+</a>
+Development Environment for Linux
+
+<li>
+<a href="http://www.vyyo.com/products/architecture_v3000.html">
+Vyyo V3000 Broadband Wireless Hub
+</a>
+
+<li>
+<a href="mailto:john_sadler@alum.mit.edu">
+<i>Your Product Name Here!!!</i>
+</a>
+
+</ul>
+
+
+<hr>
+<h2><a name="lawyerbait">License And Disclaimer</a></h2>
+
+Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+<br>
+All rights reserved.
+<p>
+
+<b>
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+<ol>
+
+<li>
+Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+<li>
+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.
+
+</ol>
+
+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.
+</b>
+<p>
+
+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
+<a href="mailto:john_sadler@alum.mit.edu">send me email</a>.
+<p>
+
+
+<h2><a name="features">Ficl Features</a></h2>
+
+<ul>
+
+<li>
+Simple to integrate into existing systems: the sample
+implementation requires three Ficl function calls (see the example
+program in <b>main.c</b>).
+
+<li>
+Written in ANSI C for portability.
+
+<li>
+Standard: Implements the ANS Forth CORE word set, part of the
+CORE EXT word set, SEARCH and SEARCH EXT, TOOLS and part of TOOLS EXT,
+LOCAL and LOCAL EXT, EXCEPTION, MEMORY, and various extras.
+
+<li>
+Extensible: you can export code written in Forth, C, or ASM in a
+straightforward way. Ficl provides open facilities for extending the
+language in an application specific way. You can even add new
+control structures (not surprising if you're familiar with Forth)
+
+<li>
+Ficl and C/C++ can interact in two ways: Ficl can wrap C code,
+and C functions can invoke Ficl code.
+
+<li>
+Ficl code is thread safe and re-entrant: your program can have one or more
+Ficl "systems", and each "system" can have one or Ficl virtual machines.
+Each Ficl virtual machine has an otherwise complete state, and each can
+be bound to a separate I/O channel (or none at all).
+An optional function called ficlLockDictionary() can control
+exclusive dictionary access. This function is stubbed out by
+default (See FICL_MULTITHREAD in sysdep.h). As long as there is only
+one "session" that can compile words into the dictionary, you do not
+need exclusive dictionary access for multithreading.
+<b>Note</b>:
+while the code is re-entrant, there are still restrictions on how you
+can use it safely in a multithreaded system. Specifically, the VM
+itself maintains state, so you generally need a VM per thread in a
+multithreaded system. If interrupt service routines make calls into Ficl
+code that alters VM state, then these generally need their
+own VM as well. Alternatively, you could provide a mutual exclusion
+mechanism to serialize access to a VM from multiple threads.
+
+<li>
+ROMable: Ficl is designed to work in RAM based and ROM code / RAM
+data environments. It does require somewhat more memory than a pure ROM
+implementation because it builds its system dictionary in RAM
+at startup time.
+
+<li>
+Written in ANSI C to be as simple as I can make it to understand,
+support, debug, and port. Compiles without complaint at <code>/Az /W4</code> (require
+ANSI C, max. warnings) under Microsoft Visual C++, and <code>-ansi</code>
+under GCC. Ports to several other toolchains and operating systems
+(notably FreeBSD and Linux flavors) exist.
+
+<li> Does full 32 bit math (but you need to implement two mixed
+precision math primitives (see sysdep.c)) </li>
+
+</ul>
+
+<hr>
+
+<h2><a name="porting">Porting Ficl</a></h2>
+
+To install Ficl on your target system, you need an ANSI C compiler and
+its runtime library. Inspect the system dependent macros and functions
+in <b>sysdep.h</tt> and <tt>sysdep.c</tt> and edit them to suit
+your system. For example, <tt>INT16</tt> is a <tt>short</tt> on some
+compilers and an <tt>int</tt> on others. Check the default <tt>CELL</tt>
+alignment controlled by <tt> FICL_ALIGN</tt>. If necessary, add new
+definitions of <tt>ficlMalloc, ficlFree, ficlRealloc</tt>, and <tt>ficlTextOut</tt>
+to work with your operating system. Finally, use <tt>testmain.c</tt> as
+a guide to installing the ficl system and one or more virtual machines
+into your code. You do not need to include <tt>testmain.c</tt> in your
+build.
+<p>
+Note: ficlLockDictionary can be left unimplemented in most
+multithreaded implementations - it's only necessary if you expect to
+have more than one thread modifying the dictionary at the same
+time. If you do decide to implement it, make sure calls to
+ficlLockDictionary can nest properly (see the comments in sysdep.h). You
+need to keep count of nested locks and unlocks and do the right
+thing.
+<p>
+
+Feel free to stub out the double precision math functions (which are
+presently implemented as inline assembly because it's so easy on many 32
+bit processors) with kludge code that only goes to 32 bit
+precision. In most applications, you won't notice the difference. If
+you're doing a lot of number crunching, consider implementing them
+correctly.
+
+
+<h3>Build Controls</h3>
+
+The file sysdep.h contains default values for build controls. Most of
+these are written such that if you define them on the compiler command
+line, the defaults are overridden. I suggest you take the defaults
+on everything below the "build controls" section until you're confident
+of your port. Beware of declaring too small a dictionary, for example.
+You need about 3200 cells for a full system, about 2000 if you
+strip out most of the "soft" words.
+
+<h3>Softcore</h3>
+Many words from all the supported wordsets are written in Forth, and
+stored as a big string that Ficl compiles when it starts. The sources
+for all of these words are in directory <b>softcore</b>. There is a
+.bat file (softcore.bat) and a PERL 5 script (softcore.pl) that convert
+Forth files into the file softcore.c, so softcore.c is really dependent
+on the Forth sources. This is not reflected in the Visual C++ project
+database. For the time being, it's a manual step. You can edit
+<b>make.bat</b> to change the list of files that contribute to
+<b>softcore.c</b>.
+
+<h3>To-Do List (target system dependent words)</h3>
+
+<ul>
+
+<li>
+Unimplemented system dependent <tt>CORE</tt> word: <tt>KEY</tt>
+(implement this yourself if you need it)
+
+<li>
+Kludged <tt>CORE</tt> word: <tt>ACCEPT</tt> (implement this
+better if you need to)
+
+</ul>
+
+<h2><a name="api">Application Programming Interface</a></h2>
+
+The following is a partial listing of functions that interface your
+system or program to Ficl. For a complete listing, see <b>ficl.h</b>
+(which is heavily commented). For examples, see <b>main.c</b> and the
+FiclWin sources (<a href="#download">below</a>).
+
+<dl>
+ <dt> <b>FICL_SYSTEM *ficlInitSystem(int nDictCells)</b> </dt>
+ <dd> Initializes Ficl's shared system data structures, and creates the
+dictionary allocating the specified number of CELLs from the heap (by a
+call to ficlMalloc) </dd>
+ <dt> <b>void ficlTermSystem(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Reclaims memory allocated for the ficl system including all
+dictionaries and all virtual machines created by vmCreate. Any uses of
+the memory allocation words (allocate and resize) are your
+problem. </dd>
+ <dt> <b>int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code,
+char flags)</b> </dt>
+ <dd> Create a primitive word in ficl's main dictionary with the given
+name, code pointer, and properties (immediate, compile only, etc) as
+described by the flags (see ficl.h for flag descriptions of
+the form FW_XXXX) </dd>
+ <dt> <b>int ficlExec(FICL_VM *pVM, char *text)</b> </dt>
+ <dd> Feed the specified C string ('\0' terminated) to the given
+virtual machine for evaluation. Returns various exception codes (VM_XXXX
+in ficl.h) to indicate the reason for returning. Normal exit
+condition is VM_OUTOFTEXT, indicating that the VM consumed the string
+successfully and is back for more. ficlExec calls can be nested, and
+the function itself is re-entrant, but note that a VM is
+static, so you have to take reasonable precautions (for example, use one
+VM per thread in a multithreaded system if you want multiple threads to
+be able to execute commands). </dd>
+ <dt> <b>int ficlExecC(FICL_VM *pVM, char *text, int nChars)</b> </dt>
+ <dd> Same as ficlExec, but takes a count indicating the length of the
+supplied string. Setting nChars to -1 is equivalent to ficlExec (expects
+'\0' termination). </dd>
+ <dt> <b>int ficlExecXT(FICL_VM *pVM, FICL_WORD *pFW)</b> </dt>
+ <dd> Same as ficlExec, but takes a pointer to a FICL_WORD instead of a
+string. Executes the word and returns after it has finished. If
+executing the word results in an exception, this function will
+re-throw the same code if it is nested under another ficlExec family
+function, or return the exception code directly if not. This function
+is useful if you need to execute the same word repeatedly -
+you save the dictionary search and outer interpreter overhead. </dd>
+ <dt> <b>void ficlFreeVM(FICL_VM *pVM)</b> </dt>
+ <dd> Removes the VM in question from the system VM list and deletes
+the&nbsp; memory allocated to it. This is an optional call, since
+ficlTermSystem will do this cleanup for you. This function is
+handy if you're going to do a lot of dynamic creation of VMs. </dd>
+ <dt> <b>FICL_VM *ficlNewVM(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Create, initialize, and return a VM from the heap using
+ficlMalloc. Links the VM into the system VM list for later reclamation
+by ficlTermSystem. </dd>
+ <dt> <b>FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name)</b> </dt>
+ <dd> Returns the address (also known as an XT in this case) of the
+specified word in the main dictionary. If not found, returns NULL. The
+address can be used in a call to ficlExecXT. </dd>
+ <dt> <b>FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the main system dictionary, or NULL if the
+system is uninitialized. </dd>
+ <dt> <b>FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the environment dictionary. This dictionary
+stores information that describes this implementation as required by the
+Standard. </dd>
+ <dt> <b>void ficlSetEnv(FICL_SYSTEM *pSys, char *name, UNS32 value)</b> </dt>
+ <dd> Enters a new constant into the environment dictionary, with the
+specified name and value. </dd>
+ <dt> <b>void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, UNS32 hi,
+UNS32 lo)</b> </dt>
+ <dd> Enters a new double-cell constant into the environment dictionary
+with the specified name and value. </dd>
+ <dt> <b>FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Returns a pointer to the locals dictionary. This function is
+defined only if FICL_WANT_LOCALS is #defined as non-zero (see sysdep.h).
+The locals dictionary is the symbol table for <a href="ficl_loc.html">local
+variables</a>. </dd>
+ <dt> <b>void ficlCompileCore(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Defined in words.c, this function builds ficl's primitives.&nbsp;
+ </dd>
+ <dt> <b>void ficlCompileSoftCore(FICL_SYSTEM *pSys)</b> </dt>
+ <dd> Defined in softcore.c, this function builds ANS required words
+and ficl extras by evaluating a text string (think of it as a memory
+mapped file ;-) ). The string itself is built from files in
+the softwords directory by PERL script softcore.pl.&nbsp; </dd>
+</dl>
+<hr>
+<table border="0" cellspacing="5" cols="2">
+ <tbody>
+ <tr>
+ <td colspan="2">
+ <h2> <a name="manifest"></a>Ficl Source Files </h2>
+ </td>
+ </tr>
+ <tr>
+ <td> <b>ficl.h</b> </td>
+ <td> Declares most public functions and all data structures.
+Includes sysdep.h and math.h </td>
+ </tr>
+ <tr>
+ <td> <b>sysdep.h</b> </td>
+ <td> Declares system dependent functions and contains build
+control macros. Edit this file to port to another system. </td>
+ </tr>
+ <tr>
+ <td> <b>math.h</b> </td>
+ <td> Declares functions for 64 bit math </td>
+ </tr>
+ <tr>
+ <td> <b>dict.c</b> </td>
+ <td> Dictionary </td>
+ </tr>
+ <tr>
+ <td> <b>ficl.c</b> </td>
+ <td> System initialization, termination, and ficlExec </td>
+ </tr>
+ <tr>
+ <td> <b>float.c</b> </td>
+ <td> Adds precompiled definitions from the optional FLOAT word
+set. Most of the file is conditioned on FICL_WANT_FLOAT </td>
+ </tr>
+ <tr>
+ <td> <b>math64.c</b> </td>
+ <td> Implementation of 64 bit math words (except the two unsigned
+primitives declared in sysdep.h and implemented in sysdep.c) </td>
+ </tr>
+ <tr>
+ <td> <b>prefix.c</b> </td>
+ <td> The optional prefix parse step (conditioned on
+FICL_EXTENDED_PREFIX). This parse step handles numeric constructs like
+0xa100, for example. See the release notes for more on parse steps. </td>
+ </tr>
+ <tr>
+ <td> <b>search.c</b> </td>
+ <td> Contains C implementations of several of the SEARCH and
+SEARCH EXT words </td>
+ </tr>
+ <tr>
+ <td> <b>softcore.c</b> </td>
+ <td> Contains all of the "soft" words - those written in Forth and
+compiled by Ficl at startup time. Sources for these words are in the
+softwords directory. The files softwords/softcore.bat and
+softwords/softcore.pl generate softcore.c from the .fr sources. </td>
+ </tr>
+ <tr>
+ <td> <b>softwords/</b> </td>
+ <td> Directory contains sources and translation scripts for the
+words defined in softcore.c. Softcore.c depends on most of the files in
+this directory. See softcore.bat for the actual list of
+files that contribute to softcore.c. This is where you'll find source
+code for the object oriented extensions. PERL script softcore.pl
+converts the .fr files into softcore.c. </td>
+ </tr>
+ <tr>
+ <td> <b>stack.c</b> </td>
+ <td> Stack methods </td>
+ </tr>
+ <tr>
+ <td> <b>sysdep.c</b> </td>
+ <td> Implementation of system dependent functions declared in
+sysdep.h </td>
+ </tr>
+ <tr>
+ <td> <b>testmain.c</b> </td>
+ <td> The main() function for unix/linux/win32 console applications
+- use this as an example to integrate ficl into your system. Also
+contains some definitions for testing - also useful in
+unix/linux/win32 land. </td>
+ </tr>
+ <tr>
+ <td> <b>tools.c</b> </td>
+ <td> Contains C implementations of TOOLS and TOOLS EXT words, the
+debugger, and debugger support words. </td>
+ </tr>
+ <tr>
+ <td> <b>vm.c</b> </td>
+ <td> Virtual Machine methods </td>
+ </tr>
+ <tr>
+ <td> <b>win32.c &amp; unix.c</b> </td>
+ <td> Platform extensions words loaded in ficl.c by
+ficlCompilePlatform() - conditioned on FICL_WANT_PLATFORM </td>
+ </tr>
+ <tr>
+ <td> <b>words.c</b> </td>
+ <td> Exports ficlCompileCore(), the run-time dictionary builder,
+and contains most precompiled CORE and CORE-EXT words. </td>
+ </tr>
+ </tbody>
+</table>
+<hr>
+<h2> <a name="extras"></a>Ficl extras </h2>
+<h3> <a name="exnumber"></a>Number syntax </h3>
+You can precede a number with "0x", as in C, and it will be interpreted
+as a hex value regardless of the value of <code>BASE</code>. Likewise,
+numbers prefixed with "0d" will be interpreted as decimal values.
+Example:
+<pre>ok&gt; decimal 123 . cr<br>123<br>ok&gt; 0x123 . cr<br>291<br>ok&gt; 0x123 x. cr<br>123<br></pre>
+Note: ficl2.05 and later - this behavior is controlled by the <a
+ href="ficl_parse.html">prefix parser</a> defined in <code>prefix.c</code>.
+You can add other prefixes by defining handlers for them in ficl
+or C.
+<h3> <a name="exsearch"></a> The <code>SEARCH</code> wordset and Ficl
+extensions </h3>
+<p> Ficl implements many of the search order words in terms of two
+primitives called <code><a href="#tosearch">&gt;SEARCH</a></code> and <code><a
+ href="#searchfrom">SEARCH&gt;</a></code>. As their names
+suggest (assuming you're familiar with Forth), they push and pop the
+search order stack. </p>
+<p> The standard does not appear to specify any conditions under which
+the search order is reset to a sane state. Ficl resets the search order
+to its default state whenever <tt>ABORT</tt> happens. This includes
+stack underflows and overflows. <tt>QUIT</tt> does not affect the search
+order. The minimum search order (set by <tt>ONLY</tt>) is equivalent
+to </p>
+<pre>FORTH-WORDLIST 1 SET-ORDER<br></pre>
+<p> There is a default maximum of 16 wordlists in the search order. This
+can be changed by redefining FICL_DEFAULT_VOCS (declared in sysdep.h). </p>
+<p> <b>Note</b>: Ficl resets the search order whenever it does <tt>ABORT</tt>.
+If you don't like this behavior, just comment out the
+dictResetSearchOrder() lines in ficlExec(). </p>
+<dl>
+ <dt> <a name="tosearch"></a><code>&gt;search ( wid -- )</code> </dt>
+ <dd> Push <tt>wid</tt> onto the search order. Many of the other search
+order words are written in terms of the <tt>SEARCH&gt;</tt> and <tt>&gt;SEARCH</tt>
+primitives. This word can be defined in ANS Forth as follows </dd>
+ <dd> <tt>: &gt;search&nbsp;&nbsp; &gt;r get-order 1+ r&gt; swap
+set-order ;</tt> </dd>
+ <dt> <a name="searchfrom"></a><tt>search&gt;&nbsp;&nbsp; ( -- wid )</tt> </dt>
+ <dd> Pop <tt>wid</tt> off the search order (can be coded in ANS Forth
+as&nbsp;<tt>: search&gt;&nbsp; get-order nip 1- set-order ;</tt> ) </dd>
+ <dt> <a name="ficlsetcurrent"></a><tt>ficl-set-current&nbsp;&nbsp; (
+wid -- old-wid )</tt> </dt>
+ <dd> Set wid as compile wordlist, leaving the previous compile
+wordlist on the stack </dd>
+ <dt> <a name="ficlvocabulary"></a><tt>ficl-vocabulary&nbsp;&nbsp; (
+nBins "name" -- )</tt> </dt>
+ <dd> Creates a <tt>ficl-wordlist</tt> with the specified number of
+hash table bins, binds it to the name, and associates the semantics of <tt>vocabulary</tt>
+with it (replaces the top wid in the search order list with
+its own wid when executed) </dd>
+ <dt> <a name="ficlwordlist"></a><tt>ficl-wordlist&nbsp;&nbsp; ( nBins
+-- wid )</tt> </dt>
+ <dd> Creates a wordlist with the specified number of hash table bins,
+and leaves the address of the wordlist on the stack. A <tt>ficl-wordlist</tt>
+behaves exactly as a regular wordlist, but it may search
+faster depending on the number of bins chosen and the number of words it
+contains at search time. As implemented in ficl, a wordlist is single
+threaded by default. <tt> ficl-named-wordlist</tt> takes a name for the
+wordlist and creates a word that pushes the <tt>wid</tt>. This is by
+contrast to <tt>VOCABULARY</tt>, which also has a name, but replaces
+the top of the search order with its <tt>wid</tt>. </dd>
+ <dt> <a name="ficlforgetwid"></a><tt>forget-wid&nbsp;&nbsp; ( wid -- )</tt> </dt>
+ <dd> Iterates through the specified wordlist and unlinks all
+definitions whose xt addresses are greater than or equal to the value of <tt>HERE</tt>,
+the dictionary fill pointer.&nbsp; </dd>
+ <dt> <a name="ficlhide"></a><tt>hide&nbsp;&nbsp; ( -- current-wid-was
+)</tt> </dt>
+ <dd> Push the <tt>hidden</tt> wordlist onto the search order, and set
+it as the current compile wordlist (unsing <tt>ficl-set-current</tt>).
+Leaves the previous compile wordlist ID. I use this word to
+hide implementation factor words that have low reuse potential so that
+they don't clutter the default wordlist. To undo the effect of hide,
+execute&nbsp; <b><tt>previous set-current</tt></b> </dd>
+ <dt> <a name="ficlhidden"></a><tt>hidden&nbsp;&nbsp; ( -- wid )</tt> </dt>
+ <dd> Wordlist for storing implementation factors of ficl provided
+words. To see what's in there, try:&nbsp; <b><tt>hide words previous
+set-current</tt></b> </dd>
+ <dt> <a name="wid-get-name"></a><tt>wid-get-name&nbsp;&nbsp; ( wid --
+c-addr u )</tt> </dt>
+ <dd> Ficl wordlists (2.05 and later) have a name property that can be
+assigned. This is used by <tt>ORDER</tt> to list the names of wordlists
+in the search order.&nbsp; </dd>
+ <dt> <a name="wid-set-name"></a><tt>wid-set-name&nbsp;&nbsp; ( c-addr
+wid -- )</tt> </dt>
+ <dd> Ficl wordlists (2.05 and later) have a name property that can be
+assigned. This is used by <tt>ORDER</tt> to list the names of wordlists
+in the search order. The name is assumed to be a \0 terminated
+string (C style), which conveniently is how Ficl stores word
+names.&nbsp; See softwords/softcore.fr definition of <tt>brand-wordlist</tt>&nbsp;</dd>
+ <dt> <a name="wid-set-super"></a><tt>wid-set-super&nbsp;&nbsp; ( wid
+-- )</tt> </dt>
+ <dd> Ficl wordlists have a parent wordlist pointer that is not
+specified in standard Forth. Ficl initializes this pointer to NULL
+whenever it creates a wordlist, so it ordinarily has no effect.
+This word sets the parent pointer to the wordlist specified on the top
+of the stack. Ficl's implementation of <tt>SEARCH-WORDLIST</tt> will
+chain backward through the parent link of the wordlist when
+searching. This simplifies Ficl's object model in that the search order
+does not need to reflect an object's class hierarchy when searching for
+a method. It is possible to implement Ficl object syntax in
+strict ANS Forth, but method finders need to manipulate the search order
+explicitly. </dd>
+</dl>
+<h3> <a name="exuser"></a>User variables </h3>
+<dl>
+ <dt> <tt>user&nbsp;&nbsp; ( -- ) name</tt> </dt>
+ <dd> Create a user variable with the given name. User variables are
+virtual machine local. Each VM allocates a fixed amount of storage for
+them. You can change the maximum number of user variables
+allowed by defining FICL_USER_CELLS on your compiiler's command line.
+Default is 16 user cells. User variables behave like <tt>VARIABLE</tt>s
+in all other respects (you use @ and ! on them, for example).
+Example: </dd>
+ <dd>
+ <dl>
+ <dd> <tt>user current-class</tt> </dd>
+ <dd> <tt>0 current-class !</tt> </dd>
+ </dl>
+ </dd>
+</dl>
+<h3> <a name="exmisc"></a>Miscellaneous </h3>
+<dl>
+ <dt> <tt>-roll&nbsp;&nbsp; ( xu xu-1 ... x0 u -- x0 xu-1 ... x1
+)&nbsp;</tt> </dt>
+ <dd> Rotate u+1 items on top of the stack after removing u. Rotation
+is in the opposite sense to <tt>ROLL</tt> </dd>
+</dl>
+<dl>
+ <dt> <a name="minusrot"></a><tt>-rot&nbsp;&nbsp; ( a b c -- c a b )</tt> </dt>
+ <dd> Rotate the top three stack entries, moving the top of stack to
+third place. I like to think of this as <tt>1<sup>1</sup>/<sub>2</sub>swap</tt>
+because it's good for tucking a single cell value behind a
+cell-pair (like an object).&nbsp; </dd>
+</dl>
+<dl>
+ <dt> <tt>.env&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> List all environment variables of the system </dd>
+ <dt> <tt>.hash&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> List hash table performance statistics of the wordlist that's
+first in the search order </dd>
+ <dt> <tt>.ver&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Display ficl version ID </dd>
+ <dt> <tt>&gt;name&nbsp;&nbsp; ( xt -- c-addr u )</tt> </dt>
+ <dd> Convert a word's execution token into the address and length of
+its name </dd>
+ <dt> <tt>body&gt;&nbsp;&nbsp; ( a-addr -- xt )</tt> </dt>
+ <dd> Reverses the effect of <tt>CORE</tt> word <tt>&gt;body</tt>
+(converts a parameter field address to an execution token) </dd>
+ <dt> <tt>compile-only</tt> </dt>
+ <dd> Mark the most recently defined word as being executable only
+while in compile state. Many <tt>immediate</tt> words have this
+property. </dd>
+ <dt> <tt>empty&nbsp;&nbsp; ( -- )</tt>&nbsp; </dt>
+ <dd> Empty the parameter stack </dd>
+ <dt> <tt>endif</tt> </dt>
+ <dd> Synonym for <tt>THEN</tt> </dd>
+ <dt> <a name="last-word"></a><tt>last-word&nbsp;&nbsp; ( -- xt )</tt> </dt>
+ <dd> Pushes the xt address of the most recently defined word. This
+applies to colon definitions, constants, variables, and words that use <tt>create</tt>.
+You can print the name of the most recently defined word
+with&nbsp; </dd>
+ <dd> <b><tt>last-word &gt;name type</tt>&nbsp;</b> </dd>
+ <dt> <tt>parse-word&nbsp;&nbsp; ( &lt;spaces&gt;name -- c-addr u )</tt> </dt>
+ <dd> Skip leading spaces and parse name delimited by a space. c-addr
+is the address within the input buffer and u is the length of the
+selected string. If the parse area is empty, the resulting
+string has a zero length. (From the Standard) </dd>
+ <dt> <a name="qfetch"></a><tt>q@&nbsp;&nbsp; ( addr -- x )</tt> </dt>
+ <dd> Fetch a 32 bit quantity from the specified address </dd>
+ <dt> <a name="qbang"></a><tt>q!&nbsp;&nbsp; ( x addr -- )</tt> </dt>
+ <dd> Store a 32 bit quantity to the specified address&nbsp; </dd>
+ <dt> <tt>w@&nbsp;&nbsp; ( addr -- x )</tt> </dt>
+ <dd> Fetch a 16 bit quantity from the specified address </dd>
+ <dt> <tt>w!&nbsp;&nbsp; ( x addr -- )</tt> </dt>
+ <dd> Store a 16 bit quantity to the specified address (the low 16 bits
+of the given value) </dd>
+ <dt> <a name="xdot"></a><tt>x.&nbsp;&nbsp; ( x -- )</tt> </dt>
+ <dd> Pop and display the value in hex format, regardless of the
+current value of <tt>BASE</tt> </dd>
+</dl>
+<h3> <a name="exficlwin"></a>Extra words defined in testmain.c (Win32
+and POSIX versions) </h3>
+<dl>
+ <dt> <tt>break&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Does nothing - just a handy place to set a debugger breakpoint </dd>
+ <dt> <tt>cd&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (
+"directory-name&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Executes the Win32 chdir() function, changing the program's
+logged directory. </dd>
+ <dt> <a name="clock"></a><tt>clock&nbsp;&nbsp; ( -- now )</tt> </dt>
+ <dd> Wrapper for the ANSI C clock() function. Returns the number of
+clock ticks elapsed since process start. </dd>
+ <dt> <a name="clockspersec"></a><tt>clocks/sec&nbsp;&nbsp; ( --
+clocks_per_sec )</tt> </dt>
+ <dd> Pushes the number of ticks in a second as returned by <tt>clock</tt> </dd>
+ <dt> <a name="ficlload"></a><tt>load&nbsp;&nbsp;&nbsp; (
+"filename&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Opens the Forth source file specified and loads it one line at a
+time, like <tt>INCLUDED (FILE)</tt> </dd>
+ <dt> <tt>pwd&nbsp;&nbsp;&nbsp;&nbsp; ( -- )</tt> </dt>
+ <dd> Prints the current working directory as set by <tt>cd</tt> </dd>
+ <dt> <tt>system&nbsp; ( "command&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Issues a command to a shell; implemented with the Win32 system()
+call. </dd>
+ <dt> <tt>spewhash&nbsp;&nbsp; ( "filename&lt;newline&gt;" -- )</tt> </dt>
+ <dd> Dumps all threads of the current compilation wordlist to the
+specified text file. This was useful when I thought there might be some
+point in attempting to optimize the hash function. I no longer
+harbor those illusions. </dd>
+</dl>
+<h3> Words defined in FiclWin only </h3>
+<dl>
+ <dt> <tt>!oreg&nbsp;&nbsp; ( c -- )</tt> </dt>
+ <dd> Set the value of the simulated LED register as specified (0..255)
+ </dd>
+ <dt> <tt>@ireg&nbsp;&nbsp; ( -- c )</tt> </dt>
+ <dd> Gets the value of the simulated switch block (0..255) </dd>
+ <dt> <tt>!dac&nbsp;&nbsp;&nbsp; ( c -- )</tt> </dt>
+ <dd> Sets the value of the bargraph control as specified. Valid values
+range from 0..255 </dd>
+ <dt> <tt>@adc&nbsp;&nbsp;&nbsp; ( -- c )</tt> </dt>
+ <dd> Fetches the current position of the slider control. Range is
+0..255 </dd>
+ <dt> <tt>status"&nbsp;&nbsp; ( "ccc&lt;quote&gt;" -- )</tt> </dt>
+ <dd> Set the mainframe window's status line to the text specified, up
+to the first trailing quote character. </dd>
+ <dt> <a name="ficlms"></a><tt><a
+ href="http://www.taygeta.com/forth/dpans10.htm#10.6.2.1905">ms</a>&nbsp;&nbsp;
+( u -- )</tt> </dt>
+ <dd> Causes the running virtual machine to sleep() for the number of
+milliseconds specified by the top-of-stack value. </dd>
+</dl>
+<hr>
+<h2> <a name="ansinfo"></a>ANS Required Information </h2>
+<b>ANS Forth System</b><br>
+<b>Providing names from the Core Extensions word set&nbsp;</b><br>
+<b>Providing the Exception word set</b><br>
+<b>Providing names from the Exception Extensions word set</b><br>
+<b>Providing the Locals word set&nbsp;</b><br>
+<b>Providing the Locals Extensions word set&nbsp;</b><br>
+<b>Providing the Memory Allocation word set</b><br>
+<b>Providing the Programming-Tools word set</b><br>
+<b>Providing names from the Programming-Tools Extensions word set</b><br>
+<b>Providing the Search-Order word set</b><br>
+<b>Providing the Search-Order Extensions word set</b>
+<h3> Implementation-defined Options </h3>
+The implementation-defined items in the following list represent
+characteristics and choices left to the discretion of the implementor,
+provided that the requirements of the Standard are met. A system
+shall document the values for, or behaviors of, each item.&nbsp;
+<ul>
+ <li> <b>aligned address requirements (3.1.3.3 Addresses);</b>&nbsp; </li>
+ <li> <br>
+ <font color="#000000">System dependent. You can change the default
+address alignment by defining FICL_ALIGN on your compiler's command
+line. The default value is set to 2 in sysdep.h. This causes
+dictionary entries and <tt>ALIGN</tt> and <tt>ALIGNED</tt> to align on 4
+byte boundaries. To align on <b>2<sup>n</sup></b> byte boundaries, set
+FICL_ALIGN to <b>n</b>.&nbsp;</font> </li>
+ <li> <b>behavior of 6.1.1320 EMIT for non-graphic characters</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Depends on target system, C runtime library,
+and your implementation of ficlTextOut().</font> </li>
+ <li> <b>character editing of 6.1.0695 ACCEPT and 6.2.1390 EXPECT</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">None implemented in the versions supplied in
+words.c. Because ficlExec() is supplied a text buffer externally, it's
+up to your system to define how that buffer will be obtained.</font> </li>
+ <li> <b>character set (3.1.2 Character types, 6.1.1320 EMIT, 6.1.1750
+KEY)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Depends on target system and implementation
+of ficlTextOut()</font> </li>
+ <li> <b>character-aligned address requirements (3.1.3.3 Addresses)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl characters are one byte each. There are
+no alignment requirements.</font> </li>
+ <li> <b>character-set-extensions matching characteristics (3.4.2
+Finding definition n<font color="#000000">ames)</font></b><font
+ color="#000000">;&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">No special processing is performed on
+characters beyond case-folding. Therefore, extended characters will not
+match their unaccented counterparts.</font> </li>
+ <li> <b>conditions under which control characters match a space
+delimiter (3.4.1.1 Delimiters)</b>;<font color="#ff6666">&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">Ficl uses the Standard C function isspace()
+to distinguish space characters. The rest is up to your library vendor.</font> </li>
+ <li> <b>format of the control-flow stack (3.2.3.2 Control-flow stack)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Uses the data stack</font> </li>
+ <li> <b>conversion of digits larger than thirty-five (3.2.1.2 Digit
+conversion)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">The maximum supported value of <tt>BASE</tt>
+is 36. Ficl will assertion fail in function ltoa of vm.c if the base is
+found to be larger than 36 or smaller than 2. There will be no
+effect if NDEBUG is defined</font>, however, other than possibly
+unexpected behavior.&nbsp; </li>
+ <li> <b>display after input terminates in 6.1.0695 ACCEPT and
+6.2.1390 EXPECT</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Target system dependent</font> </li>
+ <li> <b>exception abort sequence (as in 6.1.0680 ABORT")</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Does <tt>ABORT</tt></font> </li>
+ <li> <b>input line terminator (3.2.4.1 User input device)</b>;<font
+ color="#ff0000">&nbsp;</font> </li>
+ <li> <br>
+ <font color="#000000">Target system dependent (implementation of
+outer loop that calls ficlExec)</font> </li>
+ <li> <b>maximum size of a counted string, in characters (3.1.3.4
+Counted strings, 6.1.2450 WORD)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">255</font> </li>
+ <li> <b>maximum size of a parsed string (3.4.1 Parsing)</b>;&nbsp; </li>
+ <li> <br>
+Limited by available memory and the maximum unsigned value that can fit
+in a CELL (2<sup>32</sup>-1).&nbsp; </li>
+ <li> <b>maximum size of a definition name, in characters (3.3.1.2
+Definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl stores the first 31 characters of a
+definition name.</font> </li>
+ <li> <b>maximum string length for 6.1.1345 ENVIRONMENT?, in characters</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Same as maximum definition name length</font> </li>
+ <li> <b>method of selecting 3.2.4.1 User input device</b>;&nbsp; </li>
+ <li> <br>
+None supported. This is up to the target system&nbsp; </li>
+ <li> <b>method of selecting 3.2.4.2 User output device</b>;&nbsp; </li>
+ <li> <br>
+None supported. This is up to the target system&nbsp; </li>
+ <li> <b>methods of dictionary compilation (3.3 The Forth dictionary)</b>;&nbsp;</li>
+ <li> <b>number of bits in one address unit (3.1.3.3 Addresses)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Target system dependent. Ficl generally
+supports processors that can address 8 bit quantities, but there is no
+dependency that I'm aware of.</font> </li>
+ <li> <b>number representation and arithmetic (3.2.1.1 Internal number
+representation)</b>;&nbsp; </li>
+ <li> <br>
+System dependent. Ficl represents a CELL internally as a union that can
+hold INT32 (a signed 32 bit scalar value), UNS32 (32 bits unsigned), and
+an untyped pointer. No specific byte ordering is
+assumed.&nbsp; </li>
+ <li> <b>ranges for n, +n, u, d, +d, and ud (3.1.3 Single-cell types,
+3.1.4 Cell-pair types)</b>;&nbsp; </li>
+ <li> <br>
+Assuming a 32 bit implementation, range for signed single-cell values
+is -2<sup>31</sup>..2<sup>31</sup>-1. Range for unsigned single cell
+values is 0..2<sup>32</sup>-1. Range for signed double-cell
+values is -2<sup>63</sup>..2<sup>63</sup>-1. Range for unsigned single
+cell values is 0..2<sup>64</sup>-1.&nbsp; </li>
+ <li> <b>read-only data-space regions (3.3.3 Data space)</b>; </li>
+ <li> <br>
+None&nbsp; </li>
+ <li> <b>size of buffer at 6.1.2450 WORD (3.3.3.6 Other transient
+regions)</b>;&nbsp; </li>
+ <li> <br>
+Default is 255. Depends on the setting of nPAD in ficl.h.&nbsp; </li>
+ <li> <b>size of one cell in address units (3.1.3 Single-cell types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">System dependent, generally four.</font> </li>
+ <li> <b>size of one character in address units (3.1.2 Character types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">System dependent, generally one.</font> </li>
+ <li> <b>size of the keyboard terminal input buffer (3.3.3.5 Input
+buffers)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">This buffer is supplied by the host program.
+Ficl imposes no practical limit.</font> </li>
+ <li> <b>size of the pictured numeric output string buffer (3.3.3.6
+Other transient regions)</b>;&nbsp; </li>
+ <li> <br>
+Default is 255 characters. Depends on the setting of nPAD in
+ficl.h.&nbsp; </li>
+ <li> <b>size of the scratch area whose address is returned by
+6.2.2000 PAD (3.3.3.6 Other transient regions)</b>;&nbsp; </li>
+ <li> <br>
+Not presently supported&nbsp; </li>
+ <li> <b>system case-sensitivity characteristics (3.4.2 Finding
+definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl is not case sensitive</font> </li>
+ <li> <b>system prompt (3.4 The Forth text interpreter, 6.1.2050 QUIT)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">"ok&gt;"</font> </li>
+ <li> <b>type of division rounding (3.2.2.1 Integer division, 6.1.0100
+*/, 6.1.0110 */MOD, 6.1.0230 /, 6.1.0240 /MOD, 6.1.1890 MOD)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Symmetric</font> </li>
+ <li> <b>values of 6.1.2250 STATE when true</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">One (no others)</font> </li>
+ <li> <b>values returned after arithmetic overflow (3.2.2.2 Other
+integer operations)</b>;&nbsp; </li>
+ <li> <br>
+System dependent. Ficl makes no special checks for overflow.&nbsp; </li>
+ <li> <b>whether the current definition can be found after 6.1.1250
+DOES&gt; (6.1.0450 :)</b>.&nbsp; </li>
+ <li> <br>
+ <font color="#000000">No. Definitions are unsmudged after ; only,
+and only then if no control structure matching problems have been
+detected.</font> </li>
+</ul>
+<h3> Ambiguous Conditions </h3>
+A system shall document the system action taken upon each of the
+general or specific ambiguous conditions identified in this Standard.
+See 3.4.4 Possible actions on an ambiguous condition.&nbsp;
+<p> The following general ambiguous conditions could occur because of a
+combination of factors:&nbsp; </p>
+<ul>
+ <li> <b>a name is neither a valid definition name nor a valid number
+during text interpretation (3.4 The Forth text interpreter)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl does <tt>ABORT</tt> and prints the name
+followed by " not found".</font> </li>
+ <li> <b>a definition name exceeded the maximum length allowed
+(3.3.1.2 Definition names)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl stores the first 31 characters of the
+definition name, and uses all characters of the name in computing its
+hash code. The actual length of the name, up to 255
+characters, is stored in the definition's length field.</font> </li>
+ <li> <b>addressing a region not listed in 3.3.3 Data Space</b>;&nbsp;
+ </li>
+ <li> <br>
+ <font color="#000000">No problem: all addresses in ficl are
+absolute. You can reach any 32 bit address in Ficl's address space.</font> </li>
+ <li> <b>argument type incompatible with specified input parameter,
+e.g., passing a flag to a word expecting an n (3.1 Data types)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl makes no check for argument type
+compatibility. Effects of a mismatch vary widely depending on the
+specific problem and operands.</font> </li>
+ <li> <b>attempting to obtain the execution token, (e.g., with
+6.1.0070 ', 6.1.1550 FIND, etc.) of a definition with undefined
+interpretation semantics</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl returns a valid token, but the result of
+executing that token while interpreting may be undesirable.</font> </li>
+ <li> <b>dividing by zero (6.1.0100 */, 6.1.0110 */MOD, 6.1.0230 /,
+6.1.0240 /MOD, 6.1.1561 FM/MOD, 6.1.1890 MOD, 6.1.2214 SM/REM, 6.1.2370
+UM/MOD, 8.6.1.1820 M*/)</b>; </li>
+ <li> <br>
+ <font color="#000000">Results are target procesor dependent.
+Generally, Ficl makes no check for divide-by-zero. The target processor
+will probably throw an exception.</font> </li>
+ <li> <b>insufficient data-stack space or return-stack space (stack
+overflow)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">With FICL_ROBUST (sysdep.h) set &gt;= 2, most
+parameter stack operations are checked for underflow and overflow. Ficl
+does not check the return stack.</font> </li>
+ <li> <b>insufficient space for loop-control parameters</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">No check - Evil results.</font> </li>
+ <li> <b>insufficient space in the dictionary</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl generates an error message if the
+dictionary is too full to create a definition header. It checks <tt>ALLOT</tt>
+as well, but it is possible to make an unchecked allocation
+request that overflows the dictionary.</font> </li>
+ <li> <b>interpreting a word with undefined interpretation semantics</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Ficl protects all ANS Forth words with
+undefined interpretation semantics from being executed while in
+interpret state. It is possible to defeat this protection using
+' (tick) and <tt>EXECUTE</tt>, though.</font> </li>
+ <li> <b>modifying the contents of the input buffer or a string
+literal (3.3.3.4 Text-literal regions, 3.3.3.5 Input buffers)</b>;&nbsp;</li>
+ <li> <br>
+ <font color="#000000">Varies depending on the nature of the buffer.
+The input buffer is supplied by ficl's host function, and may reside in
+read-only memory. If so, writing the input buffer can ganerate
+an exception. String literals are stored in the dictionary, and are
+writable.</font> </li>
+ <li> <b>overflow of a pictured numeric output string</b>; </li>
+ <li> <br>
+In the unlikely event you are able to construct a pictured numeric
+string of more than 255 characters, the system will be corrupted
+unpredictably. The buffer area that holds pictured numeric
+output is at the end of the virtual machine. Whatever is mapped after
+the offending VM in memory will be trashed, along with the heap
+structures that contain it.&nbsp; </li>
+ <li> <b>parsed string overflow</b>; </li>
+ <li> <br>
+Ficl does not copy parsed strings unless asked to. Ordinarily, a string
+parsed from the input buffer during normal interpretation is left
+in-place, so there is no possibility of overflow. If you ask
+to parse a string into the dictionary, as in <tt>SLITERAL</tt>, you
+need to have enough room for the string, otherwise bad things may
+happen. This is not usually a problem.&nbsp; </li>
+ <li> <b>producing a result out of range, e.g., multiplication (using
+*) results in a value too big to be represented by a single-cell integer
+(6.1.0090 *, 6.1.0100 */, 6.1.0110 */MOD, 6.1.0570
+&gt;NUMBER, 6.1.1561 FM/MOD, 6.1.2214 SM/REM, 6.1.2370 UM/MOD, 6.2.0970
+CONVERT, 8.6.1.1820 M*/)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Value will be truncated</font> </li>
+ <li> <b>reading from an empty data stack or return stack (stack
+underflow)</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Most stack underflows are detected and
+prevented if FICL_ROBUST (sysdep.h) is set to 2 or greater. Otherwise,
+the stack pointer and size are likely to be trashed.</font> </li>
+ <li> <b>unexpected end of input buffer, resulting in an attempt to
+use a zero-length string as a name</b>;&nbsp; </li>
+ <li> <br>
+ <font color="#000000">Ficl returns for a new input buffer until a
+non-empty one is supplied.</font> </li>
+</ul>
+The following specific ambiguous conditions are noted in the glossary
+entries of the relevant words:&nbsp;
+<ul>
+ <li> <b>&gt;IN greater than size of input buffer (3.4.1 Parsing)</b> </li>
+ <li> <br>
+Bad Things occur - unpredictable bacause the input buffer is supplied
+by the host program's outer loop.&nbsp; </li>
+ <li> <b>6.1.2120 RECURSE appears after 6.1.1250 DOES&gt;</b> </li>
+ <li> <br>
+It finds the address of the definition before <tt>DOES&gt;</tt> </li>
+ <li> <b>argument input source different than current input source for
+6.2.2148 RESTORE-INPUT</b> </li>
+ <li> <br>
+Not implemented&nbsp; </li>
+ <li> <b>data space containing definitions is de-allocated (3.3.3.2
+Contiguous regions)</b> </li>
+ <li> <br>
+This is OK until the cells are overwritten with something else. The
+dictionary maintains a hash table, and the table must be updated in
+order to de-allocate words without corruption.&nbsp; </li>
+ <li> <b>data space read/write with incorrect alignment (3.3.3.1
+Address alignment)</b> </li>
+ <li> <br>
+Target processor dependent. Consequences include: none (Intel), address
+error exception (68K).&nbsp; </li>
+ <li> <b>data-space pointer not properly aligned (6.1.0150 ,, 6.1.0860
+C,)</b> </li>
+ <li> <br>
+See above on data space read/write alignment&nbsp; </li>
+ <li> <b>less than u+2 stack items (6.2.2030 PICK, 6.2.2150 ROLL)</b> </li>
+ <li> <br>
+Ficl detects a stack underflow and reports it, executing <tt>ABORT,</tt>
+as long as FICL_ROBUST is two or larger.&nbsp; </li>
+ <li> <b>loop-control parameters not available ( 6.1.0140 +LOOP,
+6.1.1680 I, 6.1.1730 J, 6.1.1760 LEAVE, 6.1.1800 LOOP, 6.1.2380 UNLOOP)</b> </li>
+ <li> <br>
+Loop initiation words are responsible for checking the stack and
+guaranteeing that the control parameters are pushed. Any underflows will
+be detected early if FICL_ROBUST is set to two or greater.
+Note however that Ficl only checks for return stack underflows at the
+end of each line of text.&nbsp; </li>
+ <li> <b>most recent definition does not have a name (6.1.1710
+IMMEDIATE)</b> </li>
+ <li> <br>
+No problem.&nbsp; </li>
+ <li> <b>name not defined by 6.2.2405 VALUE used by 6.2.2295 TO</b> </li>
+ <li> <br>
+Ficl's version of <tt>TO</tt> works correctly with <tt>VALUE</tt>s, <tt>CONSTANT</tt>s
+and <tt>VARIABLE</tt>s.&nbsp; </li>
+ <li> <b>name not found (6.1.0070 ', 6.1.2033 POSTPONE, 6.1.2510 ['],
+6.2.2530 [COMPILE])</b> </li>
+ <li> <br>
+Ficl prints an error message and does <tt>ABORT</tt> </li>
+ <li> <b>parameters are not of the same type (6.1.1240 DO, 6.2.0620
+?DO, 6.2.2440 WITHIN)</b> </li>
+ <li> <br>
+No check. Results vary depending on the specific problem.&nbsp; </li>
+ <li> <b>6.1.2033 POSTPONE or 6.2.2530 [COMPILE] applied to 6.2.2295 TO</b> </li>
+ <li> <br>
+The word is postponed correctly.&nbsp; </li>
+ <li> <b>string longer than a counted string returned by 6.1.2450 WORD</b> </li>
+ <li> <br>
+Ficl stores the first FICL_STRING_MAX-1 chars in the destination
+buffer. (The extra character is the trailing space required by the
+standard. Yuck.)&nbsp; </li>
+ <li> <b>u greater than or equal to the number of bits in a cell
+(6.1.1805 LSHIFT, 6.1.2162 RSHIFT)</b> </li>
+ <li> <br>
+Depends on target process or and C runtime library implementations of
+the &lt;&lt; and &gt;&gt; operators on unsigned values. For I386, the
+processor appears to shift modulo the number of bits in a
+cell.&nbsp; </li>
+ <li> <b>word not defined via 6.1.1000 CREATE (6.1.0550 &gt;BODY,
+6.1.1250 DOES&gt;)</b> </li>
+ <li> <br>
+ <b>words improperly used outside 6.1.0490 &lt;# and 6.1.0040 #&gt;
+(6.1.0030 #, 6.1.0050 #S, 6.1.1670 HOLD, 6.1.2210 SIGN)</b><br>
+Don't. <tt>CREATE</tt> reserves a field in words it builds for <tt>DOES&gt;</tt>to
+fill in. If you use <tt>DOES&gt;</tt> on a word not made by <tt>CREATE</tt>,
+it will overwrite the first cell of its parameter area.
+That's probably not what you want. Likewise, pictured numeric words
+assume that there is a string under construction in the VM's scratch
+buffer. If that's not the case, results may be unpleasant. </li>
+</ul>
+<h3> Locals Implementation-defined options </h3>
+<ul>
+ <li> <b>maximum number of locals in a definition (13.3.3 Processing
+locals, 13.6.2.1795 LOCALS|)</b> </li>
+ <li> <br>
+Default is 16. Change by redefining FICL_MAX_LOCALS, defined in
+sysdep.h </li>
+</ul>
+<h3> Locals Ambiguous conditions </h3>
+<ul>
+ <li> <b>executing a named local while in interpretation state
+(13.6.1.0086 (LOCAL))</b> </li>
+ <li> <br>
+Locals can be found in interpretation state while in the context of a
+definition under construction. Under these circumstances, locals behave
+correctly. Locals are not visible at all outside the scope of
+a definition.&nbsp; </li>
+ <li> <b>name not defined by VALUE or LOCAL (13.6.1.2295 TO)</b> </li>
+ <li> <br>
+See the CORE ambiguous conditions, above (no change) </li>
+</ul>
+<h3> Programming Tools Implementation-defined options </h3>
+<ul>
+ <li> <b>source and format of display by 15.6.1.2194 SEE</b> </li>
+ <li> <br>
+SEE de-compiles definitions from the dictionary. Because Ficl words are
+threaded by their header addresses, it is very straightforward to print
+the name and other characteristics of words in a definition.
+Primitives are so noted. Colon definitions are decompiled, but branch
+target labels are not reconstructed. Literals and string literals are so
+noted, and their contents displayed. </li>
+</ul>
+<h3> Search Order Implementation-defined options </h3>
+<ul>
+ <li> <b>maximum number of word lists in the search order (16.3.3
+Finding definition names, 16.6.1.2197 SET-ORDER)</b>&nbsp; </li>
+ <li> <br>
+Defaults to 16. Can be changed by redefining FICL_DEFAULT_VOCS,
+declared in sysdep.h&nbsp; </li>
+ <li> <b>minimum search order (16.6.1.2197 SET-ORDER, 16.6.2.1965 ONLY)</b>&nbsp;</li>
+ <li> <br>
+Equivalent to <tt>FORTH-WORDLIST 1 SET-ORDER</tt> </li>
+</ul>
+<h3> Search Order Ambiguous conditions </h3>
+<ul>
+ <li> <b>changing the compilation word list (16.3.3 Finding definition
+names)</b> </li>
+ <li> <br>
+Ficl stores a link to the current definition independently of the
+compile wordlist while it is being defined, and links it into the
+compile wordlist only after the definition completes
+successfully. Changing the compile wordlist mid-definition will cause
+the definition to link into the <i>new</i> compile wordlist.&nbsp; </li>
+ <li> <b>search order empty (16.6.2.2037 PREVIOUS)</b> </li>
+ <li> <br>
+Ficl prints an error message if the search order underflows, and resets
+the order to its default state.&nbsp; </li>
+ <li> <b>too many word lists in search order (16.6.2.0715 ALSO)</b> </li>
+ <li> <br>
+Ficl prints an error message if the search order overflows, and resets
+the order to its default state. </li>
+</ul>
+</div>
+</body>
+</html>
diff --git a/doc/source/generate.py b/doc/source/generate.py
new file mode 100644
index 000000000000..36a4406320ad
--- /dev/null
+++ b/doc/source/generate.py
@@ -0,0 +1,244 @@
+import cStringIO
+import os
+import re
+import shutil
+import string
+import sys
+
+
+outputStart = None
+navBarEntries = {}
+
+
+
+def ficlLinkEntry(file, title):
+ print("<a href=" + file + ".html><font color=white>" + title + "</font></a><p>\n")
+
+
+
+currentNavBarName = None
+
+def ficlAddToNavBarAs(name):
+ global currentNavBarName
+ currentNavBarName = name
+
+
+def ficlPageHeader(heading):
+ outputStart.write("""<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>""" + heading + """</TITLE>
+<style>\n
+blockquote { margin-left: 1em }\n
+</style>\n
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>\n
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+""" + heading + """
+</i></b></font>
+</td></tr>
+
+\n<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+""")
+
+ print("</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>\n")
+
+
+
+def ficlPageFooter():
+ print("\n</blockquote><p></td></tr></table></body></html>\n")
+
+
+
+sizeArray = [7, 5, 4, 3, 2]
+indentLevel = 0
+sections = None
+
+def ficlHeader(level, color, bgcolor, heading):
+ global sizeArray
+ size = str(sizeArray[level])
+
+ global indentLevel
+ global sections
+ while (indentLevel < level):
+ indentLevel += 1
+# sys.stderr.write("adding 1 to indentLevel, it's now " + str(indentLevel) + "\n\n")
+ sections.append([])
+ while (indentLevel > level):
+ indentLevel -= 1
+ subheadings = sections.pop()
+# sys.stderr.write("indentLevel is " + str(indentLevel) + ", subheadings is " + str(subheadings) + ", len(sections) is " + str(len(sections)) + ", sections is " + str(sections) + "\n\n")
+ sections[indentLevel - 1][-1][1] = subheadings
+ entry = [heading, [] ]
+# sys.stderr.write("indentLevel is " + str(indentLevel) + ", len(sections) is " + str(len(sections)) + ", sections is " + str(sections) + "\n\n")
+# sys.stderr.flush()
+ sections[indentLevel - 1].append(entry)
+
+ print("""
+<p>
+</blockquote><table border=0 bgcolor=""" + bgcolor + """ width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=""" + color + " size=" + size + "><b><i>")
+ print("<a name='" + collapse(heading) + "'>")
+ print(heading)
+ print("</a></i></b></font></td></tr></table><p><blockquote>\n")
+
+
+def ficlHeader1(heading):
+ ficlHeader(1, "#004968", "#a0a0a0", heading)
+
+def ficlHeader2(heading):
+ ficlHeader(2, "#004968", "#b8b8b8", heading)
+
+def ficlHeader3(heading):
+ ficlHeader(3, "#004968", "#d0d0d0", heading)
+
+def ficlHeader4(heading):
+ ficlHeader(4, "#004968", "#e8e8e8", heading)
+
+
+def collapse(s):
+ return string.join(s.split(), "").replace("'", "").replace("&", "").replace('"', "").replace('<', "").replace('>', "").replace('.', "").replace('?', "")
+
+def dump(f, sections):
+ for section in sections:
+ sys.stderr.write("sections is " + str(section) + "\n")
+ name = section[0]
+ f.write("<li><a href=#" + collapse(name) + "><font color=white>" + name + "</font></a>\n")
+ if len(section[1]) != 0:
+ f.write("<ul>\n")
+ dump(f, section[1])
+ f.write("</ul>\n")
+
+def process(inputfilename, outputfilename):
+ print "generating " + inputfilename
+ global indentLevel
+ indentLevel = 0
+ global sections
+ sections = []
+ global currentNavBarName
+
+ input = open(inputfilename, "r")
+ data = input.read().replace("\r", "")
+ input.close()
+ chunks = data.split("<?")
+
+ output = cStringIO.StringIO()
+
+ global outputStart
+ outputStart = cStringIO.StringIO()
+
+ stdout = sys.stdout
+
+ fauxGlobals = { }
+ fauxGlobals.update(globals())
+ fauxGlobals['__name__'] = '__ficlDocs__'
+ fauxGlobals['__doc__'] = inputfilename
+ fauxGlobals['outputStart'] = outputStart
+
+ sys.stdout = output
+ if (chunks[0] != None):
+ output.write(chunks[0])
+ for chunk in chunks[1:]:
+ (code, verbatim) = chunk.split("?>")
+ code = code.lstrip()
+ if (code[0] == "="):
+ execution = "eval"
+ code = code[1:].lstrip()
+ else:
+ execution = "exec"
+ compiled = compile(code, "[unknown]", execution)
+ if (execution == "eval"):
+ output.write(str(eval(compiled)))
+ else:
+ exec compiled
+ output.write(verbatim)
+
+ sys.stdout = stdout
+
+
+ f = open(outputfilename, "w")
+ f.write(outputStart.getvalue())
+ f.write("<p><br>\n")
+ keys = navBarEntries.keys()
+ keys.sort()
+ for name in keys:
+ filename = navBarEntries[name]
+ f.write("<a href=" + filename + ">")
+ name = name.replace(" ", "&nbsp;")
+ f.write("<font face=arial,helvetica color=white><b>" + name + "</b></font>")
+ f.write("</a><br>\n")
+# This doesn't look as pretty as I wanted, so I'm turning it off. --lch
+# if (name == currentNavBarName) and (len(sections) > 0):
+# f.write("<ul>\n")
+# dump(f, sections[0])
+# f.write("</ul>\n")
+
+ f.write(output.getvalue())
+ f.close()
+
+
+
+##
+## First, find all the documents in the current directory,
+## and look for their navBar entry.
+##
+
+for filename in os.listdir("."):
+ if filename[-3:] == ".ht":
+ file = open(filename, "rb")
+ for line in file.readlines():
+ navBar = "ficlAddToNavBarAs(\""
+ if line.strip().startswith(navBar):
+ (a, name, b) = line.split('"')
+ navBarEntries[name] = filename + "ml"
+ break
+ file.close()
+
+navBarEntries["Download"] = "http://sourceforge.net/project/showfiles.php?group_id=24441"
+
+ignored = re.compile("^((.*\.pyc?)|(.*\.zip)|\.|(\.\.))$")
+
+##
+## Second, build the doc tree (in ..), processing as necessary.
+##
+def visit(unused, directory, names):
+ for file in names:
+ if ignored.search(file):
+ continue
+ input = directory + "/" + file
+ output = "../" + input
+ if input[-3:].lower() == ".ht":
+ process(input, output + "ml")
+ elif os.path.isdir(input):
+ if not os.path.isdir(output):
+ os.mkdir(output)
+ else:
+ try:
+ shutil.copy2(input, output)
+ except IOError:
+ ## Ignore file-copy errors. It's probably
+ ## a read-only file that doesn't change.
+ ## Lazy, I know. --lch
+ None
+
+os.path.walk(".", visit, None)
+
+
diff --git a/doc/source/index.ht b/doc/source/index.ht
new file mode 100644
index 000000000000..1c66a2ed992d
--- /dev/null
+++ b/doc/source/index.ht
@@ -0,0 +1,244 @@
+<?
+ficlPageHeader("ficl")
+
+def feature(preamble, keyfeature, postscript = ""):
+ print "<p><dt>\n" + preamble + " <b><i>" + keyfeature + "</i></b> " + postscript + "\n<dd>\n"
+
+?>
+
+
+<? ficlHeader1("What is Ficl?") ?>
+
+
+Ficl is a programming language interpreter designed to be embedded
+into other systems as a command, macro, and development prototyping
+language.
+<p>
+
+Ficl is an acronym for "Forth Inspired Command Language".
+
+
+<? ficlHeader1("Ficl Features") ?>
+
+<dl>
+
+
+<? feature("Ficl is", "easy to port.") ?>
+
+<ul>
+
+<li>
+It typically takes under 2 hours to port to a new platform.
+
+<li>
+Ficl is written in strict ANSI C.
+
+<li>
+Ficl can run natively on 32- and 64-bit processors.
+
+</ul>
+
+
+
+<? feature("Ficl has a", "small memory footprint.") ?>
+
+A fully featured Win32 console version takes less than 100K
+of memory, and a minimal version is less
+than half that.
+
+
+
+<? feature("Ficl is ", "easy to integrate", "into your program.") ?>
+
+Where most Forths view themselves as the center of the system and
+expect the rest of the system to be coded in Forth, Ficl acts as a
+component of your program. It is easy to export code written in C or
+ASM to Ficl (in the style of TCL), or to invoke Ficl code from a
+compiled module.
+
+
+
+<? feature("Ficl is", "fast.") ?>
+
+Thanks to its
+<a href=http://www.complang.tuwien.ac.at/forth/threaded-code.html#switch-threading>"switch-threaded"</a>
+virtual machine design, Ficl 4 is faster than ever&mdash;about 3x the speed of Ficl 3.
+Ficl also features blindingly fast "just in time" compiling, removing the "compile" step from
+the usual compile-debug-edit iterative debugging cycle.
+
+
+
+<? feature("Ficl is a", "complete and powerful programming language.") ?>
+
+Ficl is an implementation of the FORTH language, a language providing
+a wide range of standard programming language features:
+<ul>
+
+<li>
+Integer and floating-point numbers, with a rich set of operators.
+
+<li>
+Arrays.
+
+<li>
+File I/O.
+
+<li>
+Flow control (<code>if/then/else</code> and many looping structures).
+
+<li>
+Subroutines with named arguments.
+
+<li>
+Language extensibility.
+
+<li>
+Powerful code pre-processing features.
+
+</ul>
+
+
+
+<? feature("Ficl is ", "standards-compliant.") ?>
+
+Ficl conforms to the 1994 ANSI Standard for FORTH (DPANS94).
+See <a href=dpans.html>ANS Required Information</a> for
+more detail.
+
+
+<? feature("Ficl is", "extensible.") ?>
+
+Ficl is extensible both at compile-time and at run-time.
+You can add new script functions, new native functions,
+even new control structures.
+
+
+
+
+<? feature("Ficl adds ", "object oriented programming features.") ?>
+
+Ficl's flexible OOP library can be used to wrap
+data structures or classes of the host system without altering them.
+(And remember how we said Ficl was extensible? Ficl's object-oriented
+programming extensions are written in Ficl.)
+
+
+
+<? feature("Ficl is", "interactive.") ?>
+
+Ficl can be used interactively, like most other FORTHs, Python,
+and Smalltalk. You can inspect data, run commands, or even
+define new commands, all on a running Ficl VM.
+Ficl also has a built-in script debugger that allows you to
+step through Ficl code as it is executed.
+
+
+<? feature("Ficl is", "ROMable.") ?>
+
+Ficl is designed to work in RAM based and ROM code / RAM
+data environments.
+
+
+
+<? feature("Ficl is", "safe for multithreaded programs.") ?>
+
+Ficl is reentrant and thread-safe. After initialization,
+it does not write to any global data.
+
+
+<? feature("Ficl is ", "open-source and free.") ?>
+
+The <a href=license.html>Ficl licence</a> is a BSD-style
+license, requiring only that you document that you are
+using Ficl. There are no licensing costs for using Ficl.
+
+
+</dl>
+
+
+<a name=whatsnew>
+<? ficlHeader1("What's New In Ficl 4.0?") ?>
+</a>
+
+Ficl 4.0 is a major change for Ficl. Ficl 4.0 is <i>smaller</i>,
+<i>faster</i>, <i>more powerful</i>, and <i>easier to use</i>
+than ever before. (Or your money back!)
+<p>
+
+Ficl 4.0 features a major engine rewrite. Previous versions
+of Ficl stored compiled words as an array of pointers to data
+structure; Ficl 4.0 adds "instructions", and changes over to
+mostly using a "switch-threaded" model. The result? Ficl 4.0
+is approximately <i>three times</i> as fast as Ficl 3.03.
+<p>
+
+Ficl 4.0 also adds the ability to store the "softcore" words
+as LZ77 compressed text. Decompression is so quick as to be
+nearly unmeasurable (0.00384 seconds on a 750MHz AMD Duron-based
+machine). And even with the runtime decompressor, the resulting
+Ficl executable is over 13k smaller!
+<p>
+
+Another new feature: Ficl 4.0 can take advantage of native
+support for double-word math. If your platform supports it,
+set the preprocessor symbol <code>FICL_HAVE_NATIVE_2INTEGER</code>
+to 1, and create <code>typedefs</code> for <code>ficl2Integer</code>
+and <code>ficl2Unsigned</code>.
+<p>
+
+Ficl 4.0 also features a retooled API, and a redesigned directory
+tree. The API is now far more consistent. But for those of you
+who are upgrading from Ficl 3.03 or before, you can enable API
+backwards compatibility by turning on the compile-time flag
+<code>FICL_WANT_COMPATIBILITY</code>.
+<p>
+
+Ficl 4.0 also extends support every kind of local and
+global value imaginable. Every values can individually
+be local or global, single-cell or double-cell, and
+integer or floating-point.
+And <code>TO</code> <i>always</i> does the right thing.
+<p>
+
+If you're using Ficl under Windows, you'll be happy
+to know that there's a brand-new build process.
+The Ficl build process now builds Ficl as
+<ul>
+
+<li>
+a static library (.LIB),
+
+<li>
+a dynamic library (.DLL, with a .LIB import library), and
+
+<li>
+a standalone executable (.EXE).
+
+</ul>
+
+Furthermore, each of these targets can be built in
+Debug or Release, Singlethreaded or Multithreaded,
+and optionally using the DLL version of the C runtime
+library for Multithreaded builds. (And, plus, the
+<code>/objects/common</code> nonsense is gone!)
+<p>
+
+
+Finally, Ficl 4.0 adds a <code>contrib</code>
+directory, a repository for user-contributed code that isn't
+part of the standard Ficl release. The only package there
+right now is <b>XClasses</b>, a Python-based IDL that generates
+the definition files for C++-based classes, the equivalent Ficl
+classes, and code to allow the Ficl classes to call the C++ methods.
+Using <b>XClasses</b> you can write your class once, and use it
+immediately from both C++ and Ficl.
+
+
+<? ficlHeader1("Getting Ficl") ?>
+
+You can download Ficl from the
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441>
+Ficl download page at Sourceforge</a>.
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/license.ht b/doc/source/license.ht
new file mode 100644
index 000000000000..50b92b5f1432
--- /dev/null
+++ b/doc/source/license.ht
@@ -0,0 +1,47 @@
+<?
+ficlPageHeader("ficl licensing")
+
+ficlAddToNavBarAs("Licensing")
+
+ficlHeader1("Ficl License And Disclaimer")
+
+?>
+
+<font size=+1>
+Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+<br>
+All rights reserved.
+</font>
+<p>
+
+<b>
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+<ol>
+
+<li>
+Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+<li>
+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.
+
+</ol>
+
+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.
+</b>
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/links.ht b/doc/source/links.ht
new file mode 100644
index 000000000000..743b222c3fa3
--- /dev/null
+++ b/doc/source/links.ht
@@ -0,0 +1,156 @@
+<?
+ficlPageHeader("ficl links")
+
+ficlAddToNavBarAs("Links")
+
+def linkto(href):
+ print "<p><dt>\n<a href=\"" + href + "\">" + href + "</a>\n<dd>\n"
+
+?>
+
+<? ficlHeader1("Official Ficl Pages") ?>
+
+<dl>
+
+<? linkto("http://ficl.sourceforge.net") ?>
+The official web home of Ficl.
+
+<? linkto("http://sourceforge.net/project/showfiles.php?group_id=24441") ?>
+The Ficl download page.
+
+
+</dl>
+
+
+
+<? ficlHeader1("Forth Primers And Tutorials") ?>
+
+<dl>
+
+<? linkto("http://www.phys.virginia.edu/classes/551.jvn.fall01/primer.htm") ?>
+An excellent Forth primer, by Julian Nobel.
+
+<? linkto("http://ficl.sourceforge.net/pdf/Forth_Primer.pdf") ?>
+Another excellent Forth primer, by Hans Bezemer.
+
+<? linkto("http://www.taygeta.com/forth_intro/stackflo.html") ?>
+<i>An Introduction To Forth Using Stack Flow</i> by Gordon Charton.
+Mr. Charton's stack-flow diagrams make it easy to understand how
+to manipulate the FORTH stacks.
+
+<? linkto("http://www.softsynth.com/pforth/pf_tut.htm") ?>
+Phil Burk's Forth Tutorial.
+
+</dl>
+
+
+
+<? ficlHeader1("Technical Articles On Ficl And Forth") ?>
+
+<dl>
+
+<? linkto("articles/ficlddj.pdf") ?>
+Manuscript of John Sadler's article on Ficl for January 1999 <a href=http://www.ddj.com>Dr. Dobb's Journal</a>.
+
+<? linkto("articles/jwsforml.pdf") ?>
+1998 FORML Conference paper: <i>OO Programming in Ficl,</i> written and presented by John Sadler.
+
+
+<? linkto("http://www.complang.tuwien.ac.at/forth/threaded-code.html") ?>
+Anton Ertl's description of threaded code techniques. (The FORTH-related definition
+of "threaded code" is different from&mdash;and predates&mdash;the common modern
+usage dealing with light-weight processes.) Ficl 4 uses what Ertl calls
+"switch threading".
+
+<? linkto("http://ficl.sourceforge.net/dpans/dpans.htm") ?>
+1994 Draft Proposed American National Standard for Forth.
+And surprisingly readable, as language standards go.
+
+<? linkto("http://www.taygeta.com/forthlit.html") ?>
+Forth literature index on Taygeta, a web clearinghouse of Forth links.
+
+</dl>
+
+<? ficlHeader1("Other Forth Sites Of Interest") ?>
+
+<dl>
+
+<? linkto("http://www.forth.org") ?>
+The Forth Interest Group.
+
+<? linkto("http://www.forth.com") ?>
+FORTH, Incorporated. Thirty years old and going strong.
+You might be surprised to learn that they wrote software for
+the <a href=http://www.forth.com/Content/Stories/FedEx.htm>FedEx</a>
+"SuperTracker" bar code scanners / package trackers.
+
+</dl>
+
+<table width=100% bgcolor=#e0e0e0><tr><td width=160>
+<A href="http://t.webring.com/hub?sid=&ring=forth&list"><IMG src="graphics/4ring.gif" width="155" height="140" border="0" alt="Forth Webring Logo"></A>
+</td><td>
+<? ficlHeader1("The Forth Web Ring") ?>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&prev5">Previous 5 Sites</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&prev">Previous</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&next">Next</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&id=47&next5">Next 5 Sites</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&random">Random Site</A><BR>
+<A href="http://t.webring.com/hub?sid=&ring=forth&list">List Sites</A></FONT>
+</td></tr></table>
+
+
+
+<? ficlHeader1("Some Software That Uses Ficl") ?>
+
+<ul>
+<li>
+The <a href="http://www.freebsd.org/">FreeBSD</a> boot loader
+(Daniel Sobral, Jordan Hubbard)
+
+<li>
+<a href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">
+SwitchCore
+</a>
+Gigabit Ethernet switches (&Ouml;rjan Gustavsson )
+
+<li>
+<a href="http://debuffer.sourceforge.net/">
+Palm Pilot Debuffer
+</a>
+(Eric Sessoms)
+Also see <a href=http://sonic-weasel.org/eric/ficlx/>FiclX</a>, a C++ interface to Ficl.
+
+<li>
+<a href="http://www.swcp.com/%7Ejchavez/osmond.html">
+Osmond PC Board Layout tool
+</a>
+
+<li>
+<a href="http://www.netcomsystems.com">
+NetCom Systems
+</a>
+ML7710
+
+<li>
+<a href="http://www.parview.com/ds/homepage.html">
+ParView
+</a>
+GPS system
+
+<li>
+<a href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">
+PowerPlant Software
+</a>
+Development Environment for Linux
+
+<li>
+<a href="http://www.vyyo.com/products/architecture_v3000.html">
+Vyyo V3000 Broadband Wireless Hub
+</a>
+
+</ul>
+
+(Contact us if you'd like your name and product listed here.)
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/locals.ht b/doc/source/locals.ht
new file mode 100644
index 000000000000..e75ac82c4908
--- /dev/null
+++ b/doc/source/locals.ht
@@ -0,0 +1,133 @@
+<?
+
+ficlPageHeader("local variables in Ficl")
+
+ficlAddToNavBarAs("Locals")
+
+def entry(definition, description):
+ print "<tr><td bgcolor=#e0e0e0>\n<b>" + definition + "</b>\n</td><td bgcolor=#f0f0f0>\n" + description + "\n</td></tr>\n"
+
+?>
+
+
+<? ficlHeader1("An Overview And A History") ?>
+
+
+
+Named, locally scoped variables came late to Forth. Purists feel that experienced
+Forth programmers can (and should) write supportable code using only anonymous
+stack variables and good factoring, and they complain that novices use
+global variables too frequently. But local variables cost little in terms of
+code size and execution speed, and are very convenient for OO programming
+(where stack effects are more complex).
+<p>
+
+Ficl provides excellent support
+for local variables, and the purists be damned&mdash;we use 'em all the time.
+<p>
+
+Local variables can only be declared inside a definition,
+and are only visible in that definition. Please refer to
+<a href="http://ficl.sourceforge.net/dpans/dpans13.htm">
+the ANS standard for FORTH
+</a> for more general information on local variables.
+
+
+<? ficlHeader1("John-Hopkins Forth Argument Syntax") ?>
+
+ANS Forth does not specify a complete local variable facility.
+Instead, it defines a foundation upon which to build one. Ficl comes with
+an adaptation of the Johns-Hopkins local variable syntax, as developed by John
+Hayes et al. However, Ficl extends this syntax with support for double-cell and
+floating-point numbers.
+
+<p>
+
+Here's the basic syntax of a JH-local variable declaration:
+<blockquote><code>
+<b>{</b> <i>arguments</i>
+<b>|</b> <i>locals</i>
+<b>--</b> <i>ignored</i>
+<b>}</b>
+</code></blockquote>
+(For experienced FORTH programmers: the declaration is designed to look like a stack comment,
+but it uses curly braces instead of parentheses.) Each section must list zero or more
+legal Ficl word names; comments and preprocessing are not allowed here.
+Here's what each section denotes:
+
+<ul>
+
+<li>
+The <i>arguments</i> section lists local variables which are initialized from the stack when the word executes.
+Each argument is set to the top value of the stack, starting at the rightmost argument name and moving left.
+You can have zero or more arguments.
+<p>
+
+<li>
+The <i>locals</i> section lists local variables which are set to zero when the word executes.
+You can have zero or more locals.
+<p>
+
+<li>
+Any characters between <code>--</code> and <code>}</code> are treated as a comment, and ignored.
+
+</ul>
+
+(The <code>|</code> and <code>--</code> sections are optional,
+but they must appear in the order shown if they appear at all.)
+<p>
+
+
+<? ficlHeader2("Argument Types") ?>
+
+Every time you specify a local variable (in either the <i>arguments</i> or the <i>locals</i> section),
+you can also specify the <i>type</i> of the local variable. By default, a local variable
+is a single-cell integer; you can specify that the local be a double-cell integer, and/or a
+floating-point number.
+<p>
+
+To specify the type of a local, specify one or more of the following single-character specifiers,
+followed by a colon (<code>:</code>).
+
+<table>
+
+<? entry("1", "single-cell") ?>
+
+<? entry("2", "double-cell") ?>
+
+<? entry("d", "double-cell") ?>
+
+<? entry("f", "floating-point (use floating stack)") ?>
+
+<? entry("i", "integer (use data stack)") ?>
+
+<? entry("s", "single-cell") ?>
+
+</table>
+
+For instance, the argument <code>f2:foo</code> would specify a double-width floating-point
+number.
+<p>
+
+The type specifiers are read right-to left, and when two specifiers conflict, the rightmost
+one takes priority. So <code>2is1f2:foo</code> would still specifiy a double-width floating-point
+number.
+<p>
+
+Note that this syntax <i>only works</i> for Ficl's JH-locals. Locals
+defined in some other way (say, with the FORTH standard word <code>LOCALS|</code>)
+will ignore this syntax, and the entire string will be used as the name of
+the local (type and all).
+
+<? ficlHeader2("A Simple Example") ?>
+
+<pre>
+: DEMONSTRATE-JH-LOCALS { c b a f:float -- a+b f:float*2 }
+ a b +
+ 2.0e float f*
+ ;
+</pre>
+
+<?
+ficlPageFooter()
+?> \ No newline at end of file
diff --git a/doc/source/oop.ht b/doc/source/oop.ht
new file mode 100644
index 000000000000..c928eb0795b3
--- /dev/null
+++ b/doc/source/oop.ht
@@ -0,0 +1,1224 @@
+<?
+
+ficlPageHeader("ficl oop")
+
+ficlAddToNavBarAs("OOP In Ficl")
+
+def glossaryEntry(name, description):
+ print "<dt><code>" + name + " <i>" + description + "</i></code><dd>\n"
+
+?>
+
+<? ficlHeader1("Ficl Object Oriented Programming") ?>
+
+
+Ficl's object extensions provide the traditional OO benefits of associating
+data with the code that manipulates it, and reuse through single inheritance.
+Ficl also has some unusual capabilities that support interoperation with
+systems written in C.
+<p>
+
+Some design points of Ficl's OOP system:
+
+<ul>
+
+<li>
+Ficl objects are normally late bound for safety (late binding guarantees
+that the appropriate method will always be invoked for a particular object).
+Early binding is also available, provided you know the object's class at
+compile-time.
+
+<li>
+Ficl OOP supports single inheritance, aggregation, and arrays of objects.
+
+<li>
+Classes have independent name spaces for their methods: methods are only
+visible in the context of a class or object. Methods can be overridden
+or added in subclasses; there is no fixed limit on the number of methods
+of a class or subclass.
+
+<li>
+Ficl OOP syntax is regular and unified over classes and objects. In ficl,
+all classes are objects. Class methods include the ability to subclass
+and instantiate.
+
+<li>
+Ficl can adapt legacy data structures with object wrappers. You can model
+a structure in a Ficl class, and create an instance that refers to an address
+in memory that holds an instance of the structure. The <i>ref object</i>
+can then manipulate the structure directly. This lets you wrap data structures
+written and instantiated in C.
+
+</ul>
+
+<? ficlHeader2("Object-Oriented Programming concepts") ?>
+
+If you're not familiar with object-oriented programming, you
+can click <a href="http://whatis.techtarget.com/definition/0,289893,sid9_gci212681,00.html">here</a>
+or <a href="http://www.softwaredesign.com/objects.html">here</a> for
+a general-purpose overview.
+Or click <a href="articles/oo_in_c.html#review">here</a> for a short review of object-oriented ideas,
+terms, and implementations in C.
+
+<? ficlHeader2("Acknowledgements") ?>
+
+Ficl is not the first Forth to include Object Oriented extensions. Ficl's
+OO syntax owes a debt to the work of John Hayes and Dick Pountain, among
+others. OO Ficl is different from other OO Forths in a few ways, though
+(some things never change). First, unlike several implementations, the
+syntax is documented (<a href="#ootutorial">below</a>) beyond the source
+code. In Ficl's spirit of working with C code, the OO syntax provides means
+to adapt existing data structures. I've tried to make Ficl's OO model simple
+and safe by unifying classes and objects, providing late binding by default,
+and separating namespaces so that methods and regular Forth words are not
+easily confused.
+
+
+<? ficlHeader2("Ficl Object Model") ?>
+
+All classes in Ficl are derived from the common base class
+<code><a href="#objectgloss">OBJECT</a></code>
+as shown in the <a href="#figure1">figure</a> below. All classes are instances
+of <code><a href="#glossclass">METACLASS</a></code>. This means that classes
+are objects, too. <code>METACLASS</code> implements the methods for messages
+sent to classes. Class methods create instances and subclasses, and give
+information about the class. Each class is represented by a data stucture
+of three elements:
+
+<ol>
+
+<li>
+The address (named <code>.CLASS</code> ) of a parent class, or zero if it's
+a base class (only <code>OBJECT</code> and <code>METACLASS</code> have this property).
+
+<li>
+The size (named <code>.SIZE</code> ) in address units of an instance of the
+class.
+
+<li>
+A wordlist ID (named <code>.WID</code> ) for the methods of the class.
+
+</ol>
+
+In the figure below, <code>METACLASS</code> and <code>OBJECT</code> are real system-supplied
+classes. The others are contrived to illustrate the relationships among
+derived classes, instances, and the two system base classes. The dashed
+line with an arrow at the end indicates that the object/class at the arrow
+end is an instance of the class at the other end. The vertical line with
+a triangle denotes inheritance.
+<p>
+
+Note for the curious: <code>METACLASS</code> behaves like a class&mdash;it responds
+to class messages and has the same properties as any other class. If you
+want to twist your brain in knots, you can think of <code>METACLASS</code>
+as an instance of itself.
+<p>
+
+
+<a NAME="figure1"></a><img SRC="graphics/ficl_oop.jpg" VSPACE=10 height=442 width=652>
+<br>
+
+<? ficlHeader2("Ficl Object-Oriented Syntax Tutorial") ?>
+<a NAME="ootutorial"></a>
+
+It's helpful to have some familiarity with Forth and the customary Forth
+stack notation to understand this tutorial. To get started, take a look
+at this <a href="http://www.taygeta.com/forth_intro/stackflo.html">web-based
+Forth tutorial</a>. If you're comfortable with both OO and Forth, you can
+<a href="#ootutorial-finally">jump ahead</a>.
+<p>
+
+A Ficl <a href="oo_in_c.html#object-def">object</a> associates a <a href="oo_in_c.html#class-def">class</a>
+with an <a href="oo_in_c.html#instance-def">instance</a> (the storage for
+one set of instance variables). This is done explicitly on Ficl's stack,
+in that any Ficl object is represented by a cell pair:
+<blockquote><code>( INSTANCE-address CLASS-address )</code></blockquote>
+
+The <code>INSTANCE-address</code> is the address of the object's storage, and the <code>CLASS-address</code>
+is the address of its class. Whenever a named Ficl object executes (e.g.
+when you type its name and press enter at the Ficl prompt), it leaves this
+"signature". All methods by convention expect a class and instance on the
+stack when they execute, too. In many other OO languages, including C++,
+instances contain information about their classes (a <a href="http://www.mvps.org/vbvision/vtable.htm">vtable</a>
+pointer, for example). By making this pairing explicit rather than implicit,
+Ficl can be OO about chunks of data that don't realize that they are objects,
+without sacrificing any robustness for native objects. That means that
+you can use Ficl to write object wrappers for data structures created in
+C or assembly language, as long as you can determine how they're laid out
+in memory.
+<p>
+
+Whenever you create an object in Ficl, you specify its class.
+After that, the object always pushes its class and the address of its
+<a href="http://www.aware.com/Glossary/main.htm#P">payload</a>
+(instance variable space) when invoked by name.
+<p>
+
+Classes are special kinds of objects that store the methods of their
+instances, the size of an instance's payload, and a parent class pointer.
+Classes themselves are instances of a special base class called <code>METACLASS</code>,
+and all classes inherit from class <code>OBJECT</code>. This is confusing at
+first, but it means that Ficl has a very simple syntax for constructing
+and using objects. Class methods include subclassing (<code>SUB</code>), creating
+initialized and uninitialized instances (<code>NEW</code> and <code>INSTANCE</code>),
+and creating reference instances (<code>REF</code>), described later. Classes
+also have methods for disassembling their methods (<code>SEE</code>), identifying
+themselves (<code>ID</code>), and listing their pedigree (<code>PEDIGREE</code>).
+All objects inherit (from <code>OBJECT</code>) methods for initializing instances
+and arrays of instances, for performing array operations, and for getting
+information about themselves.
+
+<? ficlHeader3("Methods And Messages") ?>
+
+Methods are the functions that objects execute in response to messages.
+A message is a request to an object for a behavior that the object supports.
+When it receives a message, the target object looks up a method that performs
+the behavior for its class, and executes it. Any specific message may be
+bound to different methods in different objects, according to class. This
+separation of messages and methods allows objects to behave <a href="http://www.whatis.com/polymorp.htm">polymorphically</a>.
+(In Ficl, methods are words defined in the context of a class, and messages
+are the names of those words.) Ficl classes associate messages with methods
+for their instances (a fancy way of saying that each class owns a wordlist).
+Ficl provides a late-binding operator <code>--></code> that sends messages
+to objects at run-time, and an early-binding operator <code>=></code>
+that compiles a specific class's method. These operators are the only supported
+way to invoke methods. Regular Forth words are not visible to the method-binding
+operators, so there's no chance of confusing a message with a regular
+word of the same name.
+
+<a NAME="ootutorial-finally"></a>
+
+<? ficlHeader2("Tutorial") ?>
+
+(Finally!)
+<p>
+
+This is a tutorial. It works best if you follow along by pasting the examples
+into <b>ficlWin</b>, the Win32 version of Ficl included with the release sources
+(or some other build that includes the OO part of <code>softcore.c</code>). If you're
+not familiar with Forth, please see one of these <a href="#links">references</a>.
+Ficl's OOP words are in vocabulary <code>OOP</code>. To put <code>OOP</code> in
+the search order and make it the compilation wordlist, type:
+<pre>
+ONLY
+ALSO OOP DEFINITIONS
+</pre>
+
+<b>Note for beginners:</b> To see the effect of the commands above, type
+<code>ORDER</code>
+after each line. You can repeat the sequence above if you like.
+<p>
+
+To start, we'll work with the two base classes <code>OBJECT</code> and <code>METACLASS</code>.
+Try this:
+<pre>
+METACLASS --> METHODS
+</pre>
+
+The line above contains three words. The first is the name of a class,
+so it pushes its signature on the stack. Since all classes are instances
+of <code>METACLASS</code>, <code>METACLASS</code> behaves as if it is an instance
+of itself (this is the only class with this property). It pushes the same
+address twice: once for the class and once for the payload, since they
+are the same. The next word finds a method in the context of a class and
+executes it. In this case, the name of the method is <code>METHODS</code>.
+Its job is to list all the methods that a class knows. What you get when
+you execute this line is a list of all the class methods Ficl provides.
+<pre>
+OBJECT --> SUB C-LED
+</pre>
+Causes the base-class <code>OBJECT</code> to derive from itself a new class
+called <code>C-LED</code>. Now we'll add some instance variables and methods to the new class.
+<p>
+
+<b>Note:</b> I like to prefix the names of classes with <code>c-</code> and the
+names of member variables with a period, but this is just a convention.
+If you don't like it, pick your own.
+<pre>
+C-BYTE OBJ: .STATE
+: INIT { 2:THIS -- }
+ THIS --> SUPER --> INIT
+ ." Initializing an instance of "
+ THIS --> CLASS --> ID TYPE CR ;
+: ON { LED# 2:THIS -- }
+ THIS --> .STATE --> GET
+ 1 LED# LSHIFT OR DUP !OREG
+ THIS --> .STATE --> SET ;
+: OFF { LED# 2:THIS -- }
+ THIS --> .STATE --> GET
+ 1 LED# LSHIFT INVERT AND DUP !OREG
+ THIS --> .STATE --> SET&NBSP; ;
+END-CLASS
+</pre>
+The first line adds an instance variable called <code>.STATE</code> to the
+class. This particular instance variable is an object&mdash;it will be an instance
+of <code>C-BYTE</code>, one of Ficl's stock classes (the source for which can be found
+in the distribution in <code>softcore/classes.fr</code>).
+<p>
+
+Next we've defined a method called <code>INIT</code>. This line also declares
+a <a href="locals.html">local variable</a> called <code>THIS</code>
+(the 2 in front tells Ficl that this is a double-cell local). All methods
+by convention expect the address of the class and instance on top of the
+stack when called. The next three lines define the behavior of <code>INIT</code> when it's called.
+It first calls its superclass's version of <code>INIT</code> (which in this
+case is "<code>OBJECT => INIT</code>"&mdash;this default implementation clears all
+instance variables). The rest displays some text and causes the instance
+to print its class name (<code>THIS --> CLASS --> ID</code>).
+<p>
+
+The <code>INIT</code>> method is special for Ficl objects: whenever
+you create an initialized instance using <code>NEW</code> or <code>NEW-ARRAY</code>,
+Ficl calls the class's <code>INIT</code> method for you on that instance. The
+default <code>INIT</code> method supplied by <code>OBJECT</code> clears the instance,
+so we didn't really need to override it in this case (see the source code
+in <code>softcore/oo.fr</code>).
+<p>
+
+The <code>ON</code> and <code>OFF</code> methods defined above hide the details
+of turning LEDs on and off. The interface to FiclWin's simulated hardware
+is handled by <code>!OREG</code>. The class keeps the LED state in a shadow
+variable (<code>.STATE</code>) so that <code>ON</code> and <code>OFF</code> can work
+in terms of LED number rather than a bitmask.
+<p>
+
+Now make an instance of the new class:
+<pre>
+C-LED --> NEW LED
+</pre>
+
+And try a few things...
+<pre>
+LED --> METHODS
+LED --> PEDIGREE
+1 LED --> ON
+1 LED --> OFF
+</pre>
+
+Or you could type this with the same effect:
+<pre>
+LED 2DUP --> METHODS --> PEDIGREE
+</pre>
+
+Notice (from the output of <code>METHODS</code>) that we've overridden the
+<code>INIT</code> method supplied by object, and added two more methods for the member
+variables. If you type <code>WORDS</code>, you'll see that these methods are
+not visible outside the context of the class that contains them. The method
+finder <code>--></code> uses the class to look up methods. You can use
+this word in a definition, as we did in <code>INIT</code>, and it performs
+late binding, meaning that the mapping from message (method name) to method
+(the code) is deferred until run-time. To see this, you can decompile the
+init method like this:
+<pre>
+C-LED --> SEE INIT
+</pre>
+
+or
+<pre>
+LED --> CLASS --> SEE INIT
+</pre>
+
+<? ficlHeader2("Early Binding") ?>
+
+Ficl also provides early binding if you ask for it. Early binding is not
+as safe as late binding, but it produces code that is more compact and
+efficient because it compiles method addresses rather then their names.
+In the preferred uses of early binding, the class is assumed to be the
+one you're defining. This kind of early binding can only be used inside
+a class definition. Early bound methods still expect to find a class and
+instance cell-pair on top of the stack when they run.
+<p>
+
+Here's an example that illustrates a potential problem:
+<pre>
+OBJECT --> SUB C1
+: M1 { 2:THIS -- } ." C1'S M1" CR ;
+: M2 { 2:THIS -- } ." Running " THIS MY=> M1 ; ( early )
+: M3 { 2:THIS -- } ." Running " THIS --> M1 ( late )
+END-CLASS
+C1 --> SUB C2
+: M1 { 2:THIS -- } ." C2'S M1" CR ;
+END-CLASS
+C2 --> NEW I2
+I2 --> M1 ( runs the M1 defined in C2 )
+I2 --> M2 ( Is this what you wanted? )
+I2 --> M3 { runs the overridden M1)
+</pre>
+
+Even though we overrode method <code>M1</code> in class <code>C2</code>, the definition of <code>M2</code> with
+early binding forced the use of <code>M1</code> as defined in <code>C1</code>. If that's what you
+want, great, but more often you'll want the flexibility of overriding parent
+class behaviors appropriately.
+
+<ol>
+
+<li>
+<code>MY=></code> binds early to a method in the class being defined,
+as in the example above.
+
+<li>
+<code>MY=[ ]</code> binds a sequence of methods in the current class.
+Useful when the class has object members. Lines like
+<code>THIS --> STATE --> SET</code> in the definition of <code>C-LED</code> above can be replaced with
+<code>THIS MY=[ STATE SET ]</code> to use early binding.
+
+<li>
+<code>=></code> (dangerous) pops a class off the stack and compiles
+the method in that class. Since you have to specify the class explicitly,
+there is a real danger that this will be out of sync with the class you
+really wanted. I recommend you use <code>MY=></code> or <code>MY=[ ]</code> instead.
+
+</ol>
+
+Early binding using <code>=></code> is dangerous because it partially
+defeats the data-to-code matching mechanism object oriented languages were
+created to provide, but it does increase run-time speed by binding the
+method at compile time. In many cases, such as the <code>INIT</code> method,
+you can be reasonably certain of the class of thing you're working on.
+This is also true when invoking class methods, since all classes are instances
+of <code>METACLASS</code>. Here's an example from the definition of <code>METACLASS</code>
+in oo.fr (don't paste this into ficlWin&mdash;it's already there):
+<pre>
+: NEW \ ( class metaclass "name" -- )
+ METACLASS => INSTANCE --> INIT ;
+</pre>
+
+Try this:
+<pre>
+METACLASS --> SEE NEW
+</pre>
+
+Decompiling the method with <code>SEE</code> shows the difference between the
+two strategies. The early bound method is compiled inline, while the late-binding
+operator compiles the method name and code to find and execute it in the
+context of whatever class is supplied on the stack at run-time.
+<p>
+
+Notice that the primitive early-binding operator <code>=></code> requires
+a class at compile time. For this reason, classes are <code>IMMEDIATE</code>,
+meaning that they push their signature at compile time or run time. I'd
+recommend that you avoid early binding until you're very comfortable with
+Forth, object-oriented programming, and Ficl's OOP syntax.
+
+<? ficlHeader2("More About Instance Variables") ?>
+
+<i>Untyped</i> instance variable methods (created by <code>CELL: CELLS: CHAR:</code>
+and <code>CHARS:</code>) just push the address of the corresponding instance
+variable when invoked on an instance of the class. It's up to you to remember
+the size of the instance variable and manipulate it with the usual Forth
+words for fetching and storing.
+<p>
+
+As advertised earlier, Ficl provides ways to objectify existing data
+structures without changing them. Instead, you can create a Ficl class
+that models the structure, and instantiate a <i>ref</i> from this class,
+supplying the address of the structure. After that, the <i>ref instance</i>
+behaves as a Ficl object, but its instance variables take on the values
+in the existing structure. Example (from <code>softcore/ficlclass.fr</code>):
+<pre>
+OBJECT SUBCLASS C-WORDLIST
+ C-WORDLIST REF: .PARENT
+ C-PTR OBJ: .NAME
+ C-CELL OBJ: .SIZE
+ C-WORD REF: .HASH ( first entry in hash table )
+
+ : ?
+ --> GET-NAME ." ficl wordlist " TYPE CR ;
+ : PUSH DROP >SEARCH ;
+ : POP 2DROP PREVIOUS ;
+ : SET-CURRENT DROP SET-CURRENT ;
+ : GET-NAME DROP WID-GET-NAME ;
+ : WORDS { 2:THIS -- }
+ THIS MY=[ .SIZE GET ] 0 DO
+ I THIS MY=[ .HASH INDEX ] ( 2list-head )
+ BEGIN
+ 2DUP --> GET-NAME TYPE SPACE
+ --> NEXT OVER
+ 0= UNTIL 2DROP CR
+ LOOP
+ ;
+END-CLASS
+</pre>
+
+In this case, <code>C-WORDLIST</code> describes Ficl's wordlist structure;
+<code>NAMED-WID</code> creates a wordlist and binds it to a ref instance of
+<code>C-WORDLIST</code>.
+The fancy footwork with <code>POSTPONE</code> and early binding is required
+because classes are immediate. An equivalent way to define <code>NAMED-WID</code> with
+late binding is:
+<pre>
+: NAMED-WID ( c-address u -- )
+ WORDLIST POSTPONE C-WORDLIST --> REF
+ ;
+</pre>
+
+To do the same thing at run-time (and call it <code>MY-WORDLIST</code>):
+
+<pre>wordlist c-wordlist --> ref my-wordlist</pre>
+
+Now you can deal with the wordlist through the ref instance:
+<pre>
+MY-WORDLIST --> PUSH
+MY-WORDLIST --> SET-CURRENT
+ORDER
+</pre>
+
+Ficl can also model linked lists and other structures that contain pointers
+to structures of the same or different types. The class constructor word
+<a href="#exampleref:"><code>REF:</code></a>
+makes an aggregate reference to a particular class. See the <a href="#glossinstance">instance
+variable glossary</a> for an <a href="#exampleref:">example</a>.
+<p>
+
+Ficl can make arrays of instances, and aggregate arrays into class descripions.
+The <a href="#glossclass">class methods</a> <code>ARRAY</code> and <code>NEW-ARRAY</code>
+create uninitialized and initialized arrays, respectively, of a class.
+In order to initialize an array, the class must define (or inherit) a reasonable
+<code>INIT</code> method. <code>NEW-ARRAY</code> invokes it on each member of the array
+in sequence from lowest to highest. Array instances and array members use
+the object methods <code>INDEX</CODE>, <CODE>NEXT</CODE>, and <CODE>PREV</code>
+to navigate. Aggregate a member array of objects using <a href="#arraycolon"><code>ARRAY:</code></a>.
+The objects are not automatically initialized in this case&mdash;your class
+initializer has to call <code>ARRAY-INIT</code> explicitly if you want
+this behavior.
+<p>
+
+For further examples of OOP in Ficl, please see the source file <code>softcore/ficlclass.fr</code>.
+This file wraps several Ficl internal data structures in objects and gives
+use examples.
+
+
+<? ficlHeader1("Ficl String Classes") ?>
+<a NAME="cstring"></a>
+
+<code>C-STRING</code> is a reasonably useful dynamic string class.
+Source code for the class is located in <code>softcore/string.fr</code>.
+Features:
+dynamic creation and resizing; deletion, char cout, concatenation, output,
+comparison; creation from quoted string constant (<code>S"</code>).
+<p>
+Examples of use:
+<pre>
+C-STRING --> NEW HOMER
+S" In this house, " HOMER --> SET
+S" we obey the laws of thermodynamics!" HOMER --> CAT
+HOMER --> TYPE
+</pre>
+
+
+<? ficlHeader2("OOP Glossary") ?>
+
+<a NAME="oopgloss"></a>
+
+<b>Note:</b> With the exception of the binding operators (the first two definitions
+here), all of the words in this section are internal factors that you don't
+need to worry about. These words provide method binding for all classes
+and instances. Also described are supporting words and execution factors.
+All are defined in <code>softcore/oo.fr</code>.
+
+<dl>
+
+<? glossaryEntry("-->", "( instance class \"method-name\" -- xn )") ?>
+
+Late binding: looks up and executes the given method in the context of
+the class on top of the stack.
+
+<? glossaryEntry("C->", "( instance class \"method-name\" -- xn exc )") ?>
+
+Late binding with <code>CATCH</code>: looks up and <code>CATCH</code>es the given
+method in the context of the class on top of the stack, pushes zero or
+exception code upon return.
+
+<? glossaryEntry("MY=>", "compilation: ( \"method-name\" -- ) execution: ( instance class -- xn )") ?>
+
+Early binding: compiles code to execute the method of the class being defined.
+Only visible and valid in the scope of a <code>--> SUB</CODE> .. <CODE>END-CLASS</code>
+class definition.
+
+<? glossaryEntry("MY=[", "compilation: ( \"obj1 obj2 .. method ]\" -- ) execution: ( instance class -- xn )") ?>
+
+Early binding: compiles code to execute a chain of methods of the class
+being defined. Only visible and valid in the scope of a <code>--> SUB</CODE>
+.. <CODE>END-CLASS</code> class definition.
+
+<? glossaryEntry("=>", "compilation: ( class metaclass \"method-name\" -- ) execution: ( instance class -- xn )") ?>
+
+Early binding: compiles code to execute the method of the class specified
+at compile time.
+
+<? glossaryEntry("do-do-instance", "") ?>
+
+When executed, causes the instance to push its <code>( INSTANCE CLASS )</code> stack
+signature. Implementation factor of <code>METACLASS --> SUB</code></b> .
+Compiles <code>.DO-INSTANCE</code> in the context of a class; <code>.DO-INSTANCE</code>
+implements the <code>DOES></code> part of a named instance.
+
+<? glossaryEntry("exec-method", "( instance class c-address u -- xn )") ?>
+
+Given the address and length of a method name on the stack, finds
+the method in the context of the specified class and invokes it. Upon entry
+to the method, the instance and class are on top of the stack, as usual.
+If unable to find the method, prints an error message and aborts.
+
+<? glossaryEntry("find-method-xt", "( class \"method-name\" -- class xt )") ?>
+
+Attempts to map the message to a method in the specified class. If successful,
+leaves the class and the execution token of the method on the stack. Otherwise
+prints an error message and aborts.
+
+<? glossaryEntry("lookup-method", "( class c-address u -- class xt )") ?>
+
+Given the address and length of a method name on the stack, finds
+the method in the context of the specified class. If unable to find the
+method, prints an error message and aborts.
+
+<? glossaryEntry("parse-method", "compilation: ( \"method-name\" -- ) execution: ( -- c-address u )") ?>
+
+Parse <code>"method-name"</code> from the input stream and compile code to push its length
+and address when the enclosing definition runs.
+</dl>
+
+<? ficlHeader3("Instance Variable Glossary") ?>
+<a NAME="glossinstance"></a>
+
+<b>Note:</b>: These words are only visible when creating a subclass! To
+create a subclass, use the <code>SUB</code> method on <code>OBJECT</code> or any
+class derived from it (<i>not</i> <code>METACLASS</code>). Source code for
+Ficl OOP is in <code>softcore/oo.fr</code>.
+<p>
+
+Instance variable words do two things: they create methods that do
+san action appropriate for the type of instance variable they represent,
+and they reserve space in the class template for the instance variable.
+We'll use the term <i>instance variable</i> to refer both to the method
+that gives access to a particular field of an object, and to the field
+itself. Rather than give esentially the same example over and over, here's
+one example that shows several of the instance variable construction words
+in use:
+
+<pre>
+OBJECT SUBCLASS C-EXAMPLE
+ CELL: .CELL0
+ C-4BYTE OBJ: .NCELLS
+ 4 C-4BYTE ARRAY: .QUAD
+ CHAR: .LENGTH
+ 79 CHARS: .NAME
+END-CLASS
+</pre>
+
+This class only defines instance variables, and it inherits some methods
+from <code>OBJECT</code>. Each untyped instance variable (<code>.CELL0</code>, <code>.LENGTH</code>,
+<code>.NAME</code>) pushes its address when executed. Each object instance variable
+pushes the address and class of the aggregate object. Similar to C, an
+array instance variable leaves its base address (and its class) when executed.
+The word <code>SUBCLASS</code> is shorthand for <code>--> sub</code> .
+
+<dl>
+
+<? glossaryEntry("CELL:", "compilation: ( offset \"name\" -- offset ) execution: ( -- cell-address )") ?>
+
+Create an untyped instance variable one cell wide. The instance variable
+leaves its payload's address when executed.
+
+<? glossaryEntry("CELLS:", "compilation: ( offset nCells \"name\" -- offset' ) execution: ( -- cell-address )") ?>
+
+Create an untyped instance variable <code>nCells</code> cells wide.
+
+<? glossaryEntry("CHAR:", "compilation: ( offset \"name\" -- offset' ) execution: ( -- cell-address )") ?>
+
+Create an untyped member variable one character wide.
+
+<? glossaryEntry("CHARS:", "compilation: ( offset nChars \"name\" -- offset' ) execution: ( -- cell-address )") ?>
+
+Create an untyped member variable <code>nChars</code> characters wide.
+
+<? glossaryEntry("OBJ:", "compilation: ( offset class metaclass \"name\" -- offset' ) execution: ( -- instance class )") ?>
+
+Aggregate an uninitialized instance of <code>CLASS</code> as a member variable
+of the class under construction.
+
+<? glossaryEntry("ARRAY:", "compilation: ( offset nObjects class metaclass \"name\" -- offset' ) execution: ( -- instance class )") ?>
+<a NAME="arraycolon"></a>
+
+Aggregate an uninitialized array of instances of the class specified as
+a member variable of the class under construction.
+
+<? glossaryEntry("EXAMPLEREF:", "compilation: ( offset class metaclass \"name\" -- offset' ) execution: ( -- ref-instance ref-class )") ?>
+
+Aggregate a reference to a class instance. There is no way to set the value
+of an aggregated ref&mdash;it's meant as a way to manipulate existing data
+structures with a Ficl OO model. For example, if your system contains a
+linked list of 4 byte quantities, you can make a class that represents
+a list element like this:
+
+<pre>
+OBJECT SUBCLASS C-4LIST
+ C-4LIST REF: .LINK
+ C-4BYTE OBJ: .PAYLOAD
+END-CLASS
+
+ADDRESS-OF-EXISTING-LIST C-4LIST --> REF MYLIST
+</pre>
+
+<dd>
+The last line binds the existing structure to an instance of the class
+we just created. The link method pushes the link value and the class <code>C_4LIST</code>,
+so that the link looks like an object to Ficl and like a struct to C (it
+doesn't carry any extra baggage for the object model&mdash;the Ficl methods
+alone take care of storing the class information).
+<p>
+
+<b>Note:</b> Since a <code>REF:</code> aggregate can only support one class, it's good for
+modeling static structures, but not appropriate for polymorphism. If you
+want polymorphism, aggregate a <code>C_REF</code> (see <code>softcore/classes.fr</code> for source)
+into your class&mdash;it has methods to set and get an object.
+<p>
+
+By the way, it is also possible to construct a pair of classes that contain
+aggregate pointers to each other. Here's an example:
+
+<pre>
+OBJECT SUBCLASS AKBAR
+ SUSPEND-CLASS \ put akbar on hold while we define jeff
+
+OBJECT SUBCLASS JEFF
+ AKBAR REF: .SIGNIFICANT-OTHER
+ ( <i>... your additional methods here ...</i> )
+END-CLASS \ done with jeff
+
+AKBAR --> RESUME-CLASS \ resume defining akbar
+ JEFF REF: .SIGNIFICANT-OTHER
+ ( <i>... your additional methods here ...</i> )
+END-CLASS \ done with akbar
+</pre>
+
+</dl>
+
+<a NAME="glossclass"></a>
+<? ficlHeader1("Class Methods Glossary") ?>
+
+These words are methods of <code>METACLASS</code>. They define the manipulations
+that can be performed on classes. Methods include various kinds of instantiation,
+programming tools, and access to member variables of classes. Source is
+in <code>softcore/oo.fr</code>.
+
+<dl>
+
+<? glossaryEntry("INSTANCE", "( class metaclass \"name\" -- instance class )") ?>
+
+Create an uninitialized instance of the class, giving it the name specified.
+The method leaves the instance's signature on the stack (handy if you
+want to initialize). Example:
+
+<pre>
+C_REF --> INSTANCE UNINIT-REF 2DROP
+</pre>
+
+<? glossaryEntry("NEW", "( class metaclass \"name\" -- )") ?>
+
+Create an initialized instance of class, giving it the name specified.
+This method calls <code>INIT</code> to perform initialization.
+
+<? glossaryEntry("ARRAY", "( nObjects class metaclass \"name\" -- nObjects instance class )") ?>
+
+Create an array of <code>nObjects</code> instances of the specified class.
+Instances are not initialized. Example:
+
+<pre>
+10 C_4BYTE --> ARRAY 40-RAW-BYTES 2DROP DROP
+</pre>
+
+
+<? glossaryEntry("NEW-ARRAY", "( nObjects class metaclass \"name\" -- )") ?>
+
+Creates an initialized array of <code>nObjects</code> instances of the class.
+Same syntax as <code>ARRAY</code>.
+
+<a NAME="alloc"></a>
+<? glossaryEntry("ALLOC", "( class metaclass -- instance class )") ?>
+
+Creates an anonymous instance of <code>CLASS</code> from the heap (using a call
+to <code>ficlMalloc()</code> to get the memory). Leaves the payload and class addresses
+on the stack. Usage example:
+
+<pre>
+C-REF --> ALLOC 2CONSTANT INSTANCE-OF-REF
+</pre>
+<p>
+
+Creates a double-cell constant that pushes the payload and class address
+of a heap instance of <code>C-REF</code>.
+
+<a NAME="allocarray"></a>
+<? glossaryEntry("ALLOC-ARRAY", "( nObjects class metaclass -- instance class )") ?>
+
+Same as <code>NEW-ARRAY</code>, but creates anonymous instances from the heap using
+a call to <code>ficlMalloc()</code>. Each instance is initialized using the class's
+<code>INIT</code> method.
+
+<a NAME="allot"></a>
+<? glossaryEntry("ALLOT", "( class metaclass -- instance class )") ?>
+
+Creates an anonymous instance of <code>CLASS</code> from the dictionary. Leaves
+the payload and class addresses on the stack. Usage example:
+
+<pre>
+C-REF --> ALLOT 2CONSTANT INSTANCE-OF-REF
+</pre>
+
+<p>
+
+Creates a double-cell constant that pushes the payload and class address
+of a heap instance of <code>C-REF</code>.
+
+<a NAME="allotarray"></a>
+<? glossaryEntry("ALLOT-ARRAY", "( nObjects class metaclass -- instance class )") ?>
+
+Same as <code>NEW-ARRAY</code>, but creates anonymous instances from the dictionary.
+Each instance is initialized using the class's <code>INIT</code> method.
+
+<? glossaryEntry("REF", "( instance-address class metaclass \"name\" -- )") ?>
+
+Make a ref instance of the class that points to the supplied instance address.
+No new instance space is allotted. Instead, the instance refers to the
+address supplied on the stack forever afterward. For wrapping existing
+structures.
+
+
+<? glossaryEntry("SUB", "( class metaclass -- old-wid address[size] size )") ?>
+
+Derive a subclass. You can add or override methods, and add instance variables.
+Alias: <code>SUBCLASS</code>. Examples:
+<p>
+
+<pre>
+C_4BYTE --> SUB C_SPECIAL4BYTE
+ ( <i>... your new methods and instance variables here ...</i> )
+END-CLASS
+</pre>
+
+or
+
+<pre>
+C_4BYTE SUBCLASS C_SPECIAL4BYTE
+ ( <i>... your new methods and instance variables here ...</i> )
+END-CLASS
+</pre>
+
+<? glossaryEntry(".SIZE", "( class metaclass -- instance-size )") ?>
+
+Returns address of the class's instance size field, in address units. This
+is a metaclass member variable.
+
+<? glossaryEntry(".SUPER", "( class metaclass -- superclass )") ?>
+
+Returns address of the class's superclass field. This is a metaclass member
+variable.
+
+<? glossaryEntry(".WID", "( class metaclass -- wid )") ?>
+
+Returns the address of the class's wordlist ID field. This is a metaclass
+member variable.
+
+<? glossaryEntry("GET-SIZE", "( -- instance-size )") ?>
+
+Returns the size of an instance of the class in address units. Imeplemented
+as follows:
+
+<pre>
+: GET-SIZE METACLASS => .SIZE @ ;
+</pre>
+
+<? glossaryEntry("GET-WID", "( -- wid )") ?>
+
+Returns the wordlist ID of the class. Implemented as:
+
+<pre>
+: GET-WID METACLASS => .WID @ ;
+</pre>
+
+<? glossaryEntry("GET-SUPER", "( -- superclass )") ?>
+
+Returns the class's superclass. Implemented as
+
+<pre>
+: GET-SUPER METACLASS => .super @ ;
+</pre>
+
+
+<? glossaryEntry("ID", "( class metaclass -- c-address u )") ?>
+
+Returns the address and length of a string that names the class.
+
+
+<? glossaryEntry("METHODS", "( class metaclass -- )") ?>
+
+Lists methods of the class and all its superclasses.
+
+
+<? glossaryEntry("OFFSET-OF", "( class metaclass \"name\" -- offset )") ?>
+
+Pushes the offset from the instance base address of the named member variable.
+If the name is not that of an instance variable method, you get garbage.
+There is presently no way to detect this error. Example:
+
+<pre>
+metaclass --> offset-of .wid
+</pre>
+
+
+<? glossaryEntry("PEDIGREE", "( class metaclass -- )") ?>
+
+
+Lists the pedigree of the class (inheritance trail).
+
+<? glossaryEntry("SEE", "( class metaclass \"name\" -- )") ?>
+
+Decompiles the specified method&mdash;obect version of <code>SEE</code>, from the
+<code>TOOLS</code> wordset.
+
+</dl>
+
+<? ficlHeader1("<code>OBJECT</code> Base-Class Methods Glossary") ?>
+<a NAME="objectgloss"></a>
+
+These are methods that are defined for all instances by the base class
+<code>OBJECT</code>.
+The methods include default initialization, array manipulations, aliases
+of class methods, upcasting, and programming tools.
+
+<dl>
+
+<? glossaryEntry("INIT", "( instance class -- )") ?>
+
+Default initializer, called automatically for all instances created with
+<code>NEW</code>
+or <code>NEW-ARRAY</code>. Zero-fills the instance. You do not normally need
+to invoke <code>INIT</code> explicitly.
+
+<? glossaryEntry("ARRAYINIT", "( nObjects instance class -- )") ?>
+
+Applies <code>INIT</code> to an array of objects created by <code>NEW-ARRAY</code>.
+Note that <code>ARRAY:</code> does not cause aggregate arrays to be initialized
+automatically. You do not normally need to invoke <code>ARRAY-INIT</code> explicitly.
+
+<? glossaryEntry("FREE", "( instance class -- )") ?>
+
+Releases memory used by an instance previously created with <code>ALLOC</code>
+or <code>ALLOC-ARRAY</code>. <b>Note:</b> This method is not presently protected
+against accidentally deleting something from the dictionary. If you do
+this, Bad Things are likely to happen. Be careful for the moment to apply
+free only to instances created with <code>ALLOC</code> or <code>ALLOC-ARRAY</code>.
+
+<? glossaryEntry("CLASS", "( instance class -- class metaclass )") ?>
+
+Convert an object signature into that of its class. Useful for calling
+class methods that have no object aliases.
+
+<? glossaryEntry("SUPER", "( instance class -- instance superclass )") ?>
+
+Upcast an object to its parent class. The parent class of <code>OBJECT</code>
+is zero. Useful for invoking an overridden parent class method.
+
+<? glossaryEntry("PEDIGREE", "( instance class -- )") ?>
+
+Display an object's pedigree&mdash;its chain of inheritance. This is an alias
+for the corresponding class method.
+
+<? glossaryEntry("SIZE", "( instance class -- instance-size )") ?>
+
+Returns the size, in address units, of one instance. Does not know about
+arrays! This is an alias for the class method <code>GET-SIZE</code>.
+
+<? glossaryEntry("METHODS", "( instance class -- )") ?>
+
+Class method alias. Displays the list of methods of the class and all superclasses
+of the instance.
+
+<? glossaryEntry("INDEX", "( n instance class -- instance[n] class )") ?>
+
+Convert array-of-objects base signature into signature for array element
+n. No check for bounds overflow. Index is zero-based, like C, so
+
+<pre>
+0 MY-OBJ --> INDEX
+</pre>
+
+is equivalent to
+
+<pre>
+MY-OBJ
+</pre>
+
+Check out the <a href="#minusrot">description of <code>-ROT</code></a> for
+help in dealing with indices on the stack.
+
+<? glossaryEntry("NEXT", "( instance[n] class -- instance[n+1] )") ?>
+
+Convert an array-object signature into the signature of the next
+object in the array. No check for bounds overflow.
+
+<? glossaryEntry("PREV", "( instance[n] class -- instance[n-1] class )") ?>
+
+Convert an object signature into the signature of the previous object
+in the array. No check for bounds underflow.
+
+</dl>
+
+
+<? ficlHeader2("Supplied Classes") ?>
+<a NAME="stockclasses"></a>
+
+For more information on theses classes, see <code>softcore/classes.fr</code>.
+
+<dl>
+
+<? glossaryEntry("METACLASS", "") ?>
+
+Describes all classes of Ficl. Contains class methods. Should never be
+directly instantiated or subclassed. Defined in <code>softcore/oo.fr</code>. Methods described
+above.
+
+<? glossaryEntry("OBJECT", "") ?>
+
+Mother of all Ficl objects. Defines default initialization and array indexing
+methods. Defined in <code>softcore/oo.fr</code>. Methods described above.
+
+<? glossaryEntry("C-REF", "") ?>
+
+Holds the signature of another object. Aggregate one of these into a data
+structure or container class to get polymorphic behavior. Methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- ref-instance ref-class )") ?>
+Push the referenced object value on the stack.
+
+<? glossaryEntry("SET", "( ref-instance ref-class instance class -- )") ?>
+Set the referenced object being held.
+
+<? glossaryEntry(".INSTANCE", "( instance class -- a-address )") ?>
+Cell member that holds the instance.
+
+<? glossaryEntry(".CLASS", "( instance class -- a-address )") ?>
+Cell member that holds the class.
+
+</dl>
+
+<? glossaryEntry("C-BYTE", "") ?>
+
+Primitive class derived from <code>OBJECT</code>, with a 1-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- byte )") ?>
+Push the object's value on the stack.
+
+<? glossaryEntry("SET", "( byte instance class -- )") ?>
+Set the object's value from the stack.
+
+<? glossaryEntry(".PAYLOAD", "( instance class -- address )") ?>
+Member holds instance's value.
+
+</dl>
+
+<? glossaryEntry("C-2BYTE", "") ?>
+
+Primitive class derived from <code>OBJECT</code>, with a 2-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- 2byte )") ?>
+Push the object's value on the stack.
+
+<? glossaryEntry("SET", "( 2byte instance class -- )") ?>
+Set the object's value from the stack.
+
+<? glossaryEntry(".PAYLOAD", "( instance class -- address )") ?>
+Member holds instance's value.
+
+</dl>
+
+<? glossaryEntry("C-4BYTE", "") ?>
+Primitive class derived from <code>object</code>, with a 4-byte payload. <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- 4byte )") ?>
+Push the object's value on the stack.
+
+<? glossaryEntry("SET", "( 4byte instance class -- )") ?>
+Set the object's value from the stack.
+
+<? glossaryEntry(".PAYLOAD", "( instance class -- address )") ?>
+Member holds instance's value.
+
+</dl>
+
+<? glossaryEntry("C-CELL", "") ?>
+
+Primitive class derived from <code>OBJECT</code>, with a cell payload (equivalent
+to <code>C-4BYTE</code> on 32 bit platforms, 64 bits wide on Alpha and other
+64-bit platforms). <code>SET</code>
+and <code>GET</code> methods perform correct width fetch and store. Methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- 4byte )") ?>
+Push the object's value on the stack.
+
+<? glossaryEntry("SET", "( 4byte instance class -- )") ?>
+Set the object's value from the stack.
+
+<? glossaryEntry(".PAYLOAD", "( instance class -- address )") ?>
+Member holds instance's value.
+
+</dl>
+
+<? glossaryEntry("C-PTR", "") ?>
+
+Base class derived from <code>OBJECT</code> for pointers to non-object types.
+This class is not complete by itself: several methods depend on a derived
+class definition of <code>@SIZE</code>. Methods and members:
+
+<dl>
+
+<? glossaryEntry(".ADDR", "( instance class -- a-address )") ?>
+Member variable, holds the pointer address.
+
+<? glossaryEntry("GET-PTR", "( instance class -- pointer )") ?>
+Pushes the pointer address.
+
+<? glossaryEntry("SET-PTR", "( pointer instance class -- )") ?>
+Sets the pointer address.
+
+<? glossaryEntry("INC-PTR", "( instance class -- )") ?>
+Adds <code>@SIZE</code> to the pointer address.
+
+<? glossaryEntry("DEC-PTR", "( instance class -- )") ?>
+Subtracts <code>@SIZE</code> to the pointer address.
+
+<? glossaryEntry("INDEX-PTR", "( i instance class -- )") ?>
+Adds <code>i * @SIZE</code> to the pointer address.
+
+</dl>
+
+<? glossaryEntry("C-BYTEPTR", "") ?>
+
+Pointer to byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<? glossaryEntry("@SIZE", "( instance class -- size )") ?>
+Push size of the pointed-to object.
+
+<? glossaryEntry("GET", "( instance class -- byte )") ?>
+Pushes the pointer's referent byte.
+
+<? glossaryEntry("SET", "( byte instance class -- )") ?>
+Stores <code>byte</code> at the pointer address.
+
+</dl>
+
+
+
+<? glossaryEntry("C-2BYTEPTR", "") ?>
+
+Pointer to 2byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<? glossaryEntry("@SIZE", "( instance class -- size )") ?>
+Push size of the pointed-to object.
+
+<? glossaryEntry("GET", "( instance class -- 2byte )") ?>
+Pushes the pointer's referent 2byte.
+
+<? glossaryEntry("SET", "( 2byte instance class -- )") ?>
+Stores <code>2byte</code> at the pointer address.
+
+</dl>
+
+
+
+<? glossaryEntry("C-4BYTEPTR", "") ?>
+
+Pointer to 4byte derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<? glossaryEntry("@SIZE", "( instance class -- size )") ?>
+Push size of the pointed-to object.
+
+<? glossaryEntry("GET", "( instance class -- 4byte )") ?>
+Pushes the pointer's referent 4byte.
+
+<? glossaryEntry("SET", "( 4byte instance class -- )") ?>
+Stores <code>4byte</code> at the pointer address.
+
+</dl>
+
+
+<? glossaryEntry("C-CELLPTR", "") ?>
+
+Pointer to cell derived from <code>C-PTR</code>. Methods and members:
+
+<dl>
+
+<? glossaryEntry("@SIZE", "( instance class -- size )") ?>
+Push size of the pointed-to object.
+
+<? glossaryEntry("GET", "( instance class -- cell )") ?>
+Pushes the pointer's referent cell.
+
+<? glossaryEntry("SET", "( cell instance class -- )") ?>
+Stores <code>cell</code> at the pointer address.
+
+</dl>
+
+
+
+<? glossaryEntry("C-STRING", "") ?>
+
+Dynamically allocated string, similar to MFC's <code>CString</code>.
+For more information, see <code>softcore/string.fr</code>.
+Partial list of methods and members:
+
+<dl>
+
+<? glossaryEntry("GET", "( instance class -- c-address u )") ?>
+Pushes the string buffer's contents as a <code>C-ADDR U</code> style string.
+
+<? glossaryEntry("SET", "( c-address u instance class -- )") ?>
+Sets the string buffer's contents to a new value.
+
+<? glossaryEntry("CAT", "( c-address u instance class -- )") ?>
+Concatenates a string to the string buffer's contents.
+
+<? glossaryEntry("COMPARE", "( c-address u instance class -- result )") ?>
+Lexical compiration of a string to the string buffer's contents.
+Return value is the same as the FORTH function <code>COMPARE</code>.
+
+<? glossaryEntry("TYPE", "( instance class -- )") ?>
+Prints the contents of the string buffer to the output stream.
+
+<? glossaryEntry("HASHCODE", "( instance class -- i )") ?>
+Returns a computed hash based on the contents of the string buffer.
+
+<? glossaryEntry("FREE", "( instance class -- )") ?>
+Releases the internal buffer.
+
+</dl>
+
+
+<? glossaryEntry("C-HASHSTRING", "") ?>
+
+Subclass of <code>C-STRING</code>, which adds a member variable to store a hashcode.
+For more information, see <code>softcore/string.fr</code>.
+
+</dl>
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/parsesteps.ht b/doc/source/parsesteps.ht
new file mode 100644
index 000000000000..ad083dce9d7a
--- /dev/null
+++ b/doc/source/parsesteps.ht
@@ -0,0 +1,234 @@
+<?
+ficlPageHeader("ficl parse steps")
+
+ficlAddToNavBarAs("Parse Steps")
+
+def entry(definition):
+ print "<dt>\n<code>" + definition + "</code>\n<dd>\n"
+
+?>
+
+
+<? ficlHeader1("Parse Steps") ?>
+
+Unlike every other FORTH we know of, Ficl features an <i>extensible
+parser chain</i>. The Ficl parser is not a monolithic function; instead,
+it is comprised of a simple tokenizer and a series of <i>parse steps</i>.
+A parse step is a step in the parser chain that handles a particular kind
+of token, acting on the token as appropriate. Example parse steps, in
+terms of traditional FORTH lore, would be the "number runner" and the
+"colon compiler".
+<p>
+
+The Ficl parser works like this:
+<ol>
+
+<li>
+Read in a new <i>token</i> (string of text with no internal whitespace).
+
+<li>
+For each parse step in the chain, call the parse step, passing in the token.
+If the parse step returns <code>FICL_TRUE</code>, that parse step must have
+handled the token appropriately; move on to the next token.
+
+<li>
+If the parser tries all the parse steps and none of them return
+<code>FICL_TRUE</code>, the token is illegal&mdash;print an error
+and reset the virtual machine.
+
+</ol>
+
+Parse steps can be written as native functions, or as Ficl script functions.
+New parse steps can be appended to the chain at any time.
+
+
+<? ficlHeader2("The Default Ficl Parse Chain") ?>
+
+These is the default Ficl parser chain, shown in order.
+
+<dl>
+
+<? entry("?word") ?>
+
+If compiling and local variable support is enabled, attempt to find the token in the local
+variable dictionary. If found, execute the token's compilation semantics and return <code>FICL_TRUE</code>.
+<p>
+
+Attempt to find the token in the system dictionary. If found, execute the token's semantics
+(may be different when compiling than when interpreting) and return <code>FICL_TRUE</code>.
+
+<? entry("?prefix") ?>
+This parse step is only active if prefix support is enabled, setting <code>FICL_WANT_PREFIX</code>
+in <code>ficl.h</code> to a non-zero value.
+Attempt to match the beginning of the token to the list of known prefixes. If there's a match,
+execute the associated prefix method and return <code>FICL_TRUE</code>.
+
+<? entry("?number") ?>
+Attempt to convert the token to a number in the present <code>BASE</code>. If successful, push the
+value onto the stack if interpreting, otherwise compile it, then return <code>FICL_TRUE</code>.
+
+<? entry("?float") ?>
+This parse step is only active if floating-point number support is enabled,
+setting <code>FICL_WANT_FLOAT</code> in <code>ficl.h</code> to a non-zero value.
+Attempt to convert the token to a floating-point number. If successful, push the
+value onto the floating-point stack if interpreting, otherwise compile it,
+then return <code>FICL_TRUE</code>.
+
+</dl>
+
+
+
+<? ficlHeader2("Adding A Parse Step From Within Ficl") ?>
+<a name=ficlparsestep></a>
+
+You can add a parse step in two ways. The first is to write a Ficl word that
+has the correct stack signature for a parse step:
+<pre>
+<i>MY-PARSE-STEP</i> ( c-addr u -- x*i flag )
+</pre>
+where <code>c-addr u</code> are the address and length of the incoming token,
+and <code>flag</code> is <code>FICL_TRUE</code> if the parse step processed
+the token and <code>FICL_FALSE</code> otherwise.
+<p>
+
+Install the parse step using <code>add-parse-step</code>.
+A trivial example:
+<pre>
+: ?silly ( c-addr u -- flag )
+ ." Oh no! Not another " type cr true ;
+' ?silly add-parse-step
+parse-order
+</pre>
+
+<? ficlHeader2("Adding A Native Parse Step") ?>
+
+The other way to add a parse step is to write it in C and add it into the
+parse chain with the following function:
+
+<pre>
+void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep step);
+</pre>
+
+<code>name</code> is the display name of the parse step in the parse chain
+(as displayed by the Ficl word <code>PARSE-ORDER</code>). <code>step</code>
+is a pointer to the code for the parse step itself,
+and must match the following declaration:
+<pre>
+typedef int (*ficlParseStep)(ficlVm *vm, ficlString s);
+</pre>
+<p>
+
+When a native parse step is run, <code>si</code> points to the incoming token.
+The parse step must return <code>FICL_TRUE</code> if it succeeds in handling the
+token, and <code>FICL_FALSE</code> otherwise.
+See <code>ficlVmParseNumber()</code> in <code>system.c</code> for an example.
+
+
+<? ficlHeader1("Prefixes") ?>
+
+What's a prefix, anyway? A prefix (contributed by Larry Hastings) is a token that's
+recognized as the beginning of another token. Its presence modifies the semantics of
+the rest of the token. An example is <code>0x</code>, which causes digits following
+it to be converted to hex regardless of the current value of <code>BASE</code>.
+<p>
+
+Caveat: Prefixes are matched in sequence, so the more of them there are,
+the slower the interpreter gets. On the other hand, because the prefix
+parse step occurs immediately after the dictionary lookup step, if you
+have a prefix for a particular purpose, using it may save time since it
+stops the parse process. Also, the Ficl interpreter is wonderfully fast,
+and most interpretation only happens once, so it's likely you won't notice
+any change in interpreter speed even if you make heavy use of prefixes.
+<p>
+
+Each prefix is a Ficl word stored in a special wordlist called <code>&lt;PREFIXES&gt;</code>. When the
+prefix parse step (<code>?prefix</code>, implemented in C as <code>ficlVmParsePrefix()</code>) is
+executed, it searches each word in <code>&lt;PREFIXES&gt;</code> in turn, comparing it with the
+initial characters of the incoming token. If a prefix matches, the parse step returns the remainder
+of the token to the input stream and executes the code associated with the prefix. This code can be
+anything you like, but it would typically do something with the remainder of the token. If the prefix
+code does not consume the rest of the token, it will go through the parse process again (which may
+be what you want).
+<p>
+
+Prefixes are defined in <code>prefix.c</code> and in <code>softcore/prefix.fr</code>.
+The best way to add prefixes is by defining them in your own code, bracketed with the special
+words <code>START-PREFIXES</code> and <code>END-PREFIXES</code>. For example, the following
+code would make <code>.(</code> a prefix.
+
+<pre>
+start-prefixes
+: .( .( ;
+end-prefixes
+</pre>
+<p>
+
+The compile-time constant <code>FICL_EXTENDED_PREFIX</code> controls the inclusion of
+several additional prefixes. This is turned off in the default build, since several
+of these prefixes alter standard behavior, but you might like them.
+
+
+<? ficlHeader1("Notes") ?>
+
+<ul>
+
+<li>
+Prefixes and parser extensions are non-standard. However, with the exception of
+prefix support, Ficl's default parse order follows the standard.
+Inserting parse steps in some other order will almost certainly break standard behavior.
+<p>
+
+<li>
+The number of parse steps that can be added to the system is limited by the value of
+<code>FICL_MAX_PARSE_STEPS</code> (defined in <code>sysdep.h</code>). The default
+maximum number is 8.
+<p>
+
+<li>
+The compile-time constant <code>FICL_EXTENDED_PREFIX</code> controls the inclusion of
+several additional prefixes. This is turned off in the default build, since several
+of these prefixes alter standard behavior, but you might like them.
+<p>
+
+
+</ul>
+
+<? ficlHeader1("Parser Glossary") ?>
+
+<dl>
+
+<? entry("PARSE-ORDER ( -- )") ?>
+
+Prints the list of parse steps, in the order in which they are called.
+
+<? entry("ADD-PARSE-STEP ( xt -- )") ?>
+
+Appends a parse step to the parse chain. <code>xt</code> is the address
+(execution token) of a Ficl word to use as the parse step. The word must be a
+legal Ficl parse step (<a href=#ficlparsestep>see above</a>).
+
+<? entry("SHOW-PREFIXES ( -- )") ?>
+
+Prints the list of all prefixes. Each prefix is a Ficl word that is executed if its name
+is found at the beginning of a token.
+
+<? entry("START-PREFIXES ( -- )") ?>
+
+Declares the beginning of a series of prefix definitions.
+Should be followed, eventually, by <code>END-PREFIXES</code>.
+(All <code>START-PREFIXES</code> does is tell the Ficl virtual machine
+to compile into the <code>&lt;PREFIXES&gt;</code> wordlist.)
+
+<? entry("END-PREFIXES ( -- )") ?>
+
+Declares the end of a series of prefix definitions.
+Should only be used after calling <code>START-PREFIXES</code>.
+(All <code>END-PREFIXES</code> does is tell the Ficl virtual machine
+to switch back to the wordlist that was in use before <code>START-PREFIXES</code> was called.)
+
+</dl>
+
+
+<?
+ficlPageFooter()
+?> \ No newline at end of file
diff --git a/doc/ficl_rel.html b/doc/source/releases.ht
index e3c499813ca6..a594bb8e02f9 100644
--- a/doc/ficl_rel.html
+++ b/doc/source/releases.ht
@@ -1,274 +1,489 @@
-<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Author" content="john sadler">
- <meta name="GENERATOR" content="Mozilla/4.73 [en] (Win98; U) [Netscape]">
- <title>Ficl Release Notes</title>
-</head>
-<body>
+<?
+ficlPageHeader("ficl release history")
-<h1>
-<b>Ficl Release Notes</b>
-</h1>
+ficlAddToNavBarAs("Release History")
+def ficlVersion(s):
+ ficlHeader1(s)
-<script language="javascript" src="ficlheader.js"></script>
+?>
+<? ficlVersion("Version 4.0.31") ?>
+<ul>
+
+<li>
+First official release of new engine as Ficl 4! Hooray!
+
+<li>
+<code>ficlDictionarySee()</code> now takes a <code>ficlCallback</code>,
+so it knows where to print to. This is because <b>ficlWin</b> only
+sets a per-VM callback, which <i>should</i> work.
+
+<li>
+<code>ficlSystemCreate()</code> now passes in the system correctly
+into the dictionaries it creates, which lets dictionaries know what
+system they're a part of.
+
+<li>
+ficlCompatibility: Forgot to add the <code>errorTextOut</code> to the
+<code>ficl_system</code> structure (though I'd remembered to add it to
+the <code>ficl_vm</code> structure). This caused the <code>ficl_system</code>
+members after <code>textOut</code> to not line up with their equivalent
+<code>ficlSystem</code> members, which did bad things. (The bad thing
+in particular was calling <code>ficlDictionaryResetSearchOrder()</code>
+resulted in diddling the <code>vm->link</code> member, which strangely
+enough resulted in double-freeing the stacks.)
+
+<li>
+Added <code>ficlStackWalk()</code>, which walks a stack from top
+to bottom and calls your specified callback with each successive
+element. Cleaned up stack-printing functions as a result.
+
+<li>
+Changed <code>MULTICALL</code> so you can explicitly specify the vtable.
+
+<li>
+Changed XClasses so it explicitly specifies the vtable for
+non-virtual classes. This means you can now call a virtual
+method when you've <code>SUPER</code>ed an object and you'll
+get the method you wanted.
+
+<li>
+XClasses improvement: when removing a thunked method, remove
+the thunk variable too. Added <code>xClass.removeMember()</code>
+to support this.
+
+<li>
+XClasses now generates runtime stack-check code (<code>_DEBUG</code>
+only) for functions thunked from C to Ficl.
+
+<li>
+<code>FICL_WANT_PLATFORM</code> is now <code>0</code> by default.
+It is now set to <code>1</code> in the appropriate <code>ficlplatform/*.h</code>.
+
+<li>
+<code>softcore/win32.fr ENVIRONMENT? COMPARE<code> needed to be case-insensitive.
+
+<li>
+Whoops! Setting <code>FICL_PLATFORM_2INTEGER</code> to 0
+didn't compile. It now does, and works fine, as proved by
+the <code>ansi</code> platform.
+
+<li>
+Another whoops: contrib/xclasses/xclasses.py assumed that <code>"</code> (a prefix
+version of <code>S"</code>) defined. Switched to <code>S"</code>, which is safer.
+
+</ul>
+
+<? ficlVersion("Version 4.0.30") ?>
+
+<ul>
+
+<li>
+Cleaned up some <code>FICL_</code> definitions. Now all <code>FICL_HAVE_*</code> constants
+(and some other odds and ends) have been moved to <code>FICL_PLATFORM_</code>.
+
+<li>
+Whoops! Setting <code>FICL_PLATFORM_2INTEGER</code> to 0 didn't
+compile. It now does, and works fine, as proved by
+the <code>"ansi"</code> platform.
+
+<li>
+Another whoops: <code>contrib/xclasses/xclasses.py</code> assumed that <code>"</code> (a prefix
+version of <code>S"</code>) defined. Switched to <code>S"</code>, which is safer.
+
+<li>
+Added <code>ficlDictionarySetConstantString()</code>. 'Cause I needed it for:
+
+<li>
+Removed the <code>"WIN32"</code> <code>ENVIRONMENT?</code> setting, and added <code>"FICL_PLATFORM_OS"</code>
+and <code>"FICL_PLATFORM_ARCHITECTURE"</code> in its place. These are both <i>strings</i>.
+Updated <code>softcore/win32.fr</code> to match.
+
+<li>
+Compatibility: improved <code>ficlTextOut()</code> behavior. It makes life slightly
+less convenient for some users, but should be an improvement overall.
+The change: <code>ficlTextOut()</code> is now a compatibility-layer function that
+calls straight through to <code>vmTextOut()</code>. Lots of old code calls <code>ficlTextOut()</code>
+(naughty!). It's now explicit that you must set the <code>textOut</code> function
+by hand if you use a custom one... which is a good habit to get in to anyway.
+
+<li>
+Improved the documentation regarding upgrading, <code>ficllocals.h</code>, and compile-time
+constants.
+
+<li>
+Fixed <code>doc/source/generate.py</code> so it gracefully fails to copy over read-only
+files.
+
+<li>
+Got rid of every <code>#ifdef</code> in the sources. We now consistently use <code>#if defined()</code>
+everywhere. Similarly, got rid of all platform-switched <code>#if</code> code (except for the
+compatibility layer, sigh).
+
+</ul>
+
+<? ficlVersion("Version 4.0.29") ?>
+
+<ul>
+
+<li>
+Documentation totally reworked and updated.
+
+<li>
+<code>oldnames</code> renamed to <code>compatibility</code>.
+And improved, so that now Ficl 4 is basically a drop-in
+replacement for Ficl 3.
+
+</ul>
+
+<? ficlVersion("Version 4.0.28") ?>
+
+<ul>
+
+<li>
+Did backwards-compatibility testing. Ficl now drops in, more or less,
+with all the old Ficl-3.03-using projects I had handy.
+
+<li>
+Got Ficl compiling and running fine on Linux.
+
+<li>
+Weaned LZ77 code from needing htonl()/ntohl().
+
+<li>
+Moved all the primitives defined in "testmain.c" to their own file,
+"extras.c", and gave it its own global entry point.
+
+<li>
+Renamed "testmain.c" to just plain "main.c".
+
+<li>
+Renamed "softwords" directory to "softcore". More symmetrical.
+
+<li>
+Renamed "softcore\softcore.bat" to "make.bat". Added support for "CLEAN".
+
+</ul>
+
+<? ficlVersion("Version 4.0.27") ?>
+<ul>
+
+<li>
+Added runtime jump-to-jump peephole optimization in the new
+switch-threaded VM.
+
+<li>
+Fixed <code>INCLUDE-FILE</code> so it rethrows an exception in the
+subordinate evaluation.
+
+<li>
+Added a separate <code>errorOut</code> function to
+<code>ficlCallback()</code>,
+so under Windows you can have a jolly popup window to
+rub your nose in your failings.
+
+</ul>
+
+<? ficlVersion("Version 4.0.26") ?>
+<ul>
-<br>&nbsp;
-<table BORDER=0 CELLPADDING=3 COLS=1 WIDTH="675" >
-<tr>
-<td>
+<li>
+Namespace policing complete. There are now <i>no</i> external symbols
+which do not start with the word <code>ficl</code>.
+
+<li>
+Removed <code>ficlVmExec()</code>, renamed <code>ficlVmExecC()</code> to
+<code>ficlVmExecuteString()</code>, changed it to take a <code>ficlString()</code>.
+This is deliberate subterfuge on my part; I suspect most
+people who currently call <code>ficlVmExec() / ficlVmExecC()</code>
+should be calling <code>ficlVmEvaluate()</code>.
+</ul>
-<h2><a NAME="whatsnew">Version 3.03</a></h2>
+<? ficlVersion("Version 4.0.25") ?>
<ul>
+
<li>
-Bugfix: Compiled floating-point numbers now work. (Floats in compiled code were simply broken in 3.02 and some previous version.)
-</li>
+First pass at support for "oldnames", and namespace policing.
+
+</ul>
+
+<? ficlVersion("Version 4.0.23") ?>
+First alpha release of Ficl 4.0 rewrite. Coded, for better
+or for worse, by Larry Hastings.
+Ficl is <i>smaller</i>, <i>faster</i>, <i>more powerful</i>,
+and <i>easier to use</i> than ever before. (Or your money back!)
+<ul>
<li>
-Newly implemented CORE EXT words: <code>CASE</code>, <code>OF</code>, <code>ENDOF</code>, and <code>ENDCASE</code>. Also added <code>FALLTHROUGH</code>, which works like <code>ENDOF</code> but jumps to the instruction just after the next <code>OF</code>.
-</li>
+Rewrote Ficl's virtual machine; Ficl now runs nearly 3x faster out-of-the-box.
+The new virtual machine is of the "big switch statement" variety.
+
+<li>
+Renamed most (probably all) external Ficl functions and data structures.
+They now make sense and are (gasp!) consistent.
+
<li>
-New words: <code>random</code>, <code>seed-random</code>, and <code>(lookup-method)</code>
-</li>
+Retooled double-cell number support to take advantage of platforms
+which natively support double-cell-sized integers. (Like most modern
+32-bit platforms.)
+
+<li>
+Locals and VALUEs are now totally orthogonal; they can be single- or
+double-cell, and use the float or data stack. TO automatically supports all variants.
+
+<li>
+The "softcore" words can now be stored compressed, with a (current)
+savings of 11k. Decompression is nigh-instantaneous. You can choose
+whether or not you want softcore stored compressed at compile-time.
+
+<li>
+Reworked Win32 build process. Ficl now builds out-of-the-box on Win32
+as a static library, as a DLL, and as a command-line program,
+in each of the six possible runtime variants (Debug,Release x Singlethreaded,
+Multithreaded,Multithreaded DLL).
+
+<li>
+There's very likely other wonderful things that I've long forgotten
+about. If you notice them, feel free to remind me :)
+
+</ul>
+
+<? ficlVersion("Version 3.03") ?>
+<ul>
+<li>
+Bugfix for floating-point numbers. Floats in compiled code were simply broken.
+
+<li>
+New words: <code>random</code> and <code>seed-random</code>
+
<li>
Bugfix: <code>included</code> never closed its file.
-</li>
+
<li>
Bugfix: <code>include</code> was not <code>IMMEDIATE</code>.
-</li>
-<li>
-Bugfix: John-Hopkins locals syntax now accepts <code>|</code> and <code>--</code> in the comment (between the first <code>--</code> and the <code>}</code>.)
-</li>
+
<li>
Un-hid the OO words <code>parse-method</code>, <code>lookup-method</code>, and <code>find-method-xt</code>, as there are perfectly legitimate reasons why you might want to use them.
-</li>
+
<li>
Changed the prefix version of <code>.(</code> to be <code>IMMEDIATE</code> too.
-</li>
-<li>
-Bugfix: Changed <code>vmGetWord0()</code> to make Purify happier. The resulting code is no slower, no larger, and slightly more robust.
-</li>
-<li>
-Got rid of the <code>/objects/common/ficl</code> nonsense in the VC++ project. Build-time files are now stored their default places, in relative directories called <code>debug</code> and <code>release</code>.
-</li>
+
<li>
Fixed comment in Python softcore builder.
-</li>
+
<li>
Put the <b>doc</b> directory back in to the distribution. (It was missing from 3.02... where'd it go?)
-</li>
+
</ul>
-<h2>Version 3.02</h2>
+<? ficlVersion("Version 3.02") ?>
<ul>
<li>
Added support for <code>nEnvCells</code> (number of environment cells) to <code>FICL_SYSTEM_INFO</code>.
-</li>
+
<li>
Consolidated <code>context</code> and <code>pExtend</code> pointers of <code>FICL_SYSTEM</code>&#151;VM's <code>pExtend</code> pointer is initialized from the copy in <code>FICL_SYSTEM</code> upon VM creation.
-</li>
+
<li>
Added <code>ficl-robust</code> environment variable.
-</li>
+
<li>
Added <code>FW_ISOBJECT</code> word type.
-</li>
+
<li>
Bugfix: <code>environment?</code> was ignoring the length of the supplied string.
-</li>
+
<li>
Portability cleanup in fileaccess.c.
-</li>
+
<li>
Bugfix in <code>ficlParsePrefix</code>: if the prefix dictionary isn't in the wordlist, the word being examined cannot be a prefix, so return failure.
-</li>
+
<li>
<code>SEE</code> improvements: <code>SEE</code> (and consequently <code>DEBUG</code>) have improved source listings with instruction offsets.
-</li>
+
<li>
It's turned off with the preprocessor, but we have the beginnings of a switch-threaded implementation of the inner loop.
-</li>
+
<li>
Added <code>objectify</code> and <code>?object</code> for use by OO infrastructure.
-</li>
+
<li>
<code>my=[</code> detects object members (using <code>?object</code>) and assumes all other members leave class unchanged.
-</li>
+
<li>
Removed <code>MEMORY-EXT</code> environment variable (there is no such wordset).
-</li>
+
<li>
Ficlwin changes:
<ul>
<li>
Ficlwin character handling is more robust
-</li>
+
<li>
Ficlwin uses multi-system constructs (see ficlthread.c)
-</li>
+
</ul>
-</li>
+
<li>
Documentation changes:
<ul>
<li>
Corrected various bugs in docs.
-</li>
+
<li>
Added ficl-ized version of JV Noble's Forth Primer
-</li>
+
<li>
Ficl OO tutorial expanded and revised. Thanks to David McNab for his demo and suggestions.
-</li>
+
</ul>
-</li>
+
</ul>
-<h2>Version 3.01</h2>
+<? ficlVersion("Version 3.01") ?>
<ul>
<li>
-Major contribs by Larry Hastings (larry@hastings.org):
+Major contributionss by Larry Hastings (larry@hastings.org):
<ul>
<li>
FILE wordset (fileaccess.c)
-</li>
+
<li>
ficlEvaluate wrapper for ficlExec
-</li>
+
<li>
ficlInitSystemEx makes it possible to bind selectable properties to VMs at create time
-</li>
+
<li>
Python version of softcore builder ficl/softwords/softcore.py
-</li>
+
</ul>
-</li>
+
<li>
Environment contains ficl-version (double)
-</li>
+
<li>
?number handles trailing decimal point per DOUBLE wordset spec
-</li>
+
<li>
Fixed broken .env (thanks to Leonid Rosin for spotting this goof)
-</li>
+
<li>
Fixed broken floating point words that depended on evaluation order of stack pops.
-</li>
+
<li>
env-constant
-</li>
+
<li>
env-2constant
-</li>
+
<li>
dictHashSummary is now commented out unless FICL_WANT_FLOAT (thanks to Leonid Rosin again)
-</li>
+
<li>
Thanks to David McNab for pointing out that .( should be IMMEDIATE. Now it is.
-</li>
+
</ul>
-<h2>Version 3.00a</h2>
+<? ficlVersion("Version 3.00a") ?>
<ul>
<li>
Fixed broken oo.fr by commenting out vcall stuff using FICL_WANT_VCALL. Vcall is still broken.
-</li>
+
</ul>
-<h2>Version 3.00</h2>
+<? ficlVersion("Version 3.00") ?>
<ul>
<li>
Added pSys parameter to most ficlXXXX functions for multiple system support. Affected functions:
<ul>
-<li>dictLookupLoc renamed to ficlLookupLoc after addition of pSys param</li>
-<li>ficlInitSystem returns a FICL_SYSTEM*</li>
-<li>ficlTermSystem</li>
-<li>ficlNewVM</li>
-<li>ficlLookup</li>
-<li>ficlGetDict</li>
-<li>ficlGetEnv</li>
-<li>ficlSetEnv</li>
-<li>ficlSetEnvD</li>
-<li>ficlGetLoc</li>
-<li>ficlBuild</li>
-</ul>
-</li>
-
-<li>Fixed off-by-one bug in ficlParsePrefix</li>
-<li>Ficl parse-steps now work correctly - mods to interpret()</li>
-<li>Made tools.c:isAFiclWord more selective</li>
-<li>Tweaked makefiles and code to make gcc happy under linux</li>
+<li>dictLookupLoc renamed to ficlLookupLoc after addition of pSys param
+<li>ficlInitSystem returns a FICL_SYSTEM*
+<li>ficlTermSystem
+<li>ficlNewVM
+<li>ficlLookup
+<li>ficlGetDict
+<li>ficlGetEnv
+<li>ficlSetEnv
+<li>ficlSetEnvD
+<li>ficlGetLoc
+<li>ficlBuild
+</ul>
+
+
+<li>Fixed off-by-one bug in ficlParsePrefix
+<li>Ficl parse-steps now work correctly - mods to interpret()
+<li>Made tools.c:isAFiclWord more selective
+<li>Tweaked makefiles and code to make gcc happy under linux
<li>Vetted all instances of LVALUEtoCELL to make sure they're working on CELL sized operands
-(for 64 bit compatibility)</li>
+(for 64 bit compatibility)
</ul>
-<h2>Version 2.06</h2>
+<? ficlVersion("Version 2.06") ?>
<ul>
-<li>Debugger changes:</li>
+<li>Debugger changes:
<ul>
-<li>New debugger command "x" to execute the rest of the command line as ficl</li>
-<li>New debugger command "l" lists the source of the innermost word being debugged</li>
-<li>If you attempt to debug a primitive, it gets executed rather than doing nothing</li>
-<li><code>R.S</code> displays the stack contents symbolically</li>
-<li>Debugger now operates correctly under ficlwin, although ficlwin's key handling leaves a lot to be desired. </li>
-<li><code>SEE</code> listing enhanced for use with the debugger</li>
+<li>New debugger command "x" to execute the rest of the command line as ficl
+<li>New debugger command "l" lists the source of the innermost word being debugged
+<li>If you attempt to debug a primitive, it gets executed rather than doing nothing
+<li><code>R.S</code> displays the stack contents symbolically
+<li>Debugger now operates correctly under ficlwin, although ficlwin's key handling leaves a lot to be desired.
+<li><code>SEE</code> listing enhanced for use with the debugger
</ul>
-<li>Added Guy Carver's changes to oo.fr for VTABLE support</li>
-<li><code>float.c</code> words f&gt; and &gt;f to move floats to and from the param stack, analogous to &gt;r and r&gt;</li>
+<li>Added Guy Carver's changes to oo.fr for VTABLE support
+<li><code>float.c</code> words f&gt; and &gt;f to move floats to and from the param stack, analogous to &gt;r and r&gt;
<li><code>LOOKUP</code> - Surrogate precompiled parse step for ficlParseWord (this step is hard
- coded in <code>INTERPRET</code>)</li>
-<li>License text at top of source files changed from LGPL to BSD by request</li>
+ coded in <code>INTERPRET</code>)
+<li>License text at top of source files changed from LGPL to BSD by request
<li>Win32 console version now handles exceptions more gracefully rather than crashing - uses win32
-structured exception handling.</li>
-<li>Fixed BASE bug from 2.05 (was returning the value rather than the address) </li>
+structured exception handling.
+<li>Fixed BASE bug from 2.05 (was returning the value rather than the address)
<li>Fixed ALLOT bug - feeds address units to dictCheck, which expects Cells. Changed dictCheck
-to expect AU. </li>
-<li>Float stack display word renamed to f.s from .f to be consistent with r.s and .s</li>
+to expect AU.
+<li>Float stack display word renamed to f.s from .f to be consistent with r.s and .s
</ul>
-<h2>Version 2.05</h2>
+<? ficlVersion("Version 2.05") ?>
<h3>General</h3>
<ul>
-<li>HTML documentation extensively revised</li>
-<li>Incorporated Alpha (64 bit) patches from the freeBSD team.</li>
-<li>Split SEARCH and SEARCH EXT words from words.c to search.c</li>
-<li><a href="ficl_loc.html">2LOCALS</a> defined in <a href="ficl_loc.html#jhlocal">Johns Hopkins local syntax</a> now lose the first '2:' in their names.</li>
-<li>Simple step <a href="ficl_debug.html">debugger</a> (see tools.c)</li>
+<li>HTML documentation extensively revised
+<li>Incorporated Alpha (64 bit) patches from the freeBSD team.
+<li>Split SEARCH and SEARCH EXT words from words.c to search.c
+<li><a href="ficl_loc.html">2LOCALS</a> defined in <a href="ficl_loc.html#jhlocal">Johns Hopkins local syntax</a> now lose the first '2:' in their names.
+<li>Simple step <a href="ficl_debug.html">debugger</a> (see tools.c)
<li>The text interpreter is now extensible - this is accomplished through the use
of <code>ficlAddParseStep()</code>. <code>FICL_MAX_PARSE_STEPS</code> limits the number of parse steps
(default: 8). You can write a precompiled parse step (see <code>ficlParseNumber</code>) and
append it to the chain, or you can write one in ficl and use <code>ADD-PARSE-STEP</code>
to append it. Default parse steps are initialized in <code>ficlInitSystem</code>. You can list
-the parse steps with <code>parse-order ( -- )</code>.</li>
+the parse steps with <code>parse-order ( -- )</code>.
<li>There is now a FICL_SYSTEM structure. This is a transitional release - version 3.0
will alter several API prototypes to take this as a parameter, allowing multiple
systems per process (and therefore multiple dictionaries). For those who use ficl
under a virtual memory O/S like Linux or Win NT, you can just create multiple ficl
-processes (not threads) instead and save youself the wait.</li>
-<li>Fixes for improved command line operation in testmain.c (Larry Hastings)</li>
+processes (not threads) instead and save youself the wait.
+<li>Fixes for improved command line operation in testmain.c (Larry Hastings)
<li>Numerous extensions to OO facility, including a new allot methods, ability
-to catch method invocations (thanks to Daniel Sobral again)</li>
+to catch method invocations (thanks to Daniel Sobral again)
<li>Incorporated Alpha (64 bit) patches contributed by Daniel Sobral and the freeBSD team
-Ficl is now 64 bit friendly! UNS32 is now FICL_UNS.</li>
-<li>Split SEARCH and SEARCH EXT words from words.c to search.c</li>
-<li>ABORT" now complies with the ANS (-2 THROWs)</li>
-<li>Floating point support contributed by Guy Carver (Enable FICL_WANT_FLOAT in sysdep.h).</li>
-<li>Win32 vtable model for objects (Guy Carver)</li>
-<li>Win32 dll load/call suport (Larry Hastings)</li>
+Ficl is now 64 bit friendly! UNS32 is now FICL_UNS.
+<li>Split SEARCH and SEARCH EXT words from words.c to search.c
+<li>ABORT" now complies with the ANS (-2 THROWs)
+<li>Floating point support contributed by Guy Carver (Enable FICL_WANT_FLOAT in sysdep.h).
+<li>Win32 vtable model for objects (Guy Carver)
+<li>Win32 dll load/call suport (Larry Hastings)
<li>Prefix support (Larry Hastings) (prefix.c prefix.fr FICL_EXTENDED_PREFIX) makes it
easy to extend the parser to recignize prefixes like 0x and act on them. Use show-prefixes
-to see what's defined.</li>
+to see what's defined.
<li>Cleaned up initialization sequence so that it's all in ficlInitSystem, and so that
-a VM can be created successfully before the dictionary is created</li>
+a VM can be created successfully before the dictionary is created
</ul>
<h3>
@@ -277,15 +492,15 @@ Bug fixes</h3>
<ul>
<li>
<a href="http://www.taygeta.com/forth/dpans9.htm#9.6.2.0680">ABORT"</a>
-now works correctly (I promise!)</li>
+now works correctly (I promise!)
<li>
<a href="http://www.taygeta.com/forth/dpans6.htm#6.2.2125">REFILL</a> works
-better</li>
+better
<li>
<a href="http://www.taygeta.com/forth/dpans6.htm#6.1.0710">ALLOT</a>'s
-use of dictCheck corrected (finally)</li>
+use of dictCheck corrected (finally)
</ul>
<h3>
@@ -294,41 +509,41 @@ New words</h3>
<ul>
<li>
<a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0415">2r@</a> <a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0410">2r></a> <a href="http://www.taygeta.com/forth/dpans6.htm#6.2.0340">2>r</a>
-(CORE EXT)</li>
+(CORE EXT)
<li>
<a href="http://www.taygeta.com/forth/dpans8.htm#8.6.1.0440">2VARIABLE</a>
-(DOUBLE)</li>
+(DOUBLE)
<li>
<a href="http://www.taygeta.com/forth/dpans16.htm#16.6.2.1985">ORDER</a>
-now lists wordlists by name</li>
+now lists wordlists by name
<li>
<a href="http://www.taygeta.com/forth/dpans15.htm#15.6.1.0220">.S</a> now
-displays all stack entries on one line, like a stack comment</li>
+displays all stack entries on one line, like a stack comment
<li>
<a href="ficl.html#wid-get-name"><tt>wid-get-name</tt>&nbsp;</a>&nbsp;
given a wid, returns the address and count of its name. If no name, count
-is 0</li>
+is 0
<li>
<tt><a href="ficl.html#wid-set-name">wid-set-name</a></tt>&nbsp;
-set optional wid name pointer to the \0 terminated string address specified.</li>
+set optional wid name pointer to the \0 terminated string address specified.
<li>
<tt><a href="ficl.html#ficlwordlist">ficl-named-wordlist</a></tt> creates
a ficl-wordlist and names it. This is now used in <tt>vocabulary</tt> and
-<tt><a href="ficl.html#ficlvocabulary">ficl-vocabulary</a></tt>&nbsp;</li>
+<tt><a href="ficl.html#ficlvocabulary">ficl-vocabulary</a></tt>&nbsp;
<li>
<tt><a href="ficl.html#last-word">last-word</a></tt>&nbsp; returns the
-xt of the word being defined or most recently defined.</li>
+xt of the word being defined or most recently defined.
<li>
<tt><a href="ficl.html#qfetch">q@</a></tt> and <tt><a href="ficl.html#qbang">q!</a></tt>
-operate on quadbyte quantities for 64 bit friendliness</li>
+operate on quadbyte quantities for 64 bit friendliness
</ul>
<h3>
@@ -336,31 +551,31 @@ New OO stuff</h3>
<ul>
<li>
-<tt>ALLOT (class method)</tt></li>
+<tt>ALLOT (class method)</tt>
<li>
-<tt>ALLOT-ARRAY (class method)</tt></li>
+<tt>ALLOT-ARRAY (class method)</tt>
<li>
-<tt>METHOD</tt> define method names globally</li>
+<tt>METHOD</tt> define method names globally
<li>
-<tt>MY=></tt> early bind a method call to "this" class</li>
+<tt>MY=></tt> early bind a method call to "this" class
<li>
<tt>MY=[ ]</tt> early bind a string of method calls to "this" class and
-obj members</li>
+obj members
<li>
-<tt>C-></tt> late bind method invocation with CATCH</li>
+<tt>C-></tt> late bind method invocation with CATCH
<li>
Metaclass method <tt>resume-class</tt> and instance word <tt>suspend-class</tt>
-create mutually referring classes. Example in string.fr</li>
+create mutually referring classes. Example in string.fr
<li>
Early binding words are now in the instance-vars wordlist, not visible
-unless defining a class.</li>
+unless defining a class.
<li>Support for refs to classes with VTABLE methods (contributed by Guy Carver). Guy writes:
<p>
@@ -407,19 +622,17 @@ myfclass -> ref dude \ This makes the MyCAddress pointer a myfclass
1234 1 dude -> iTest(int,char) . \ Calls iTest and emits the returned int.
dude -> fTest() f. \ Calls fTest and emits the returned float.
</pre>
-</li>
+
</ul>
-<h2>
-Version 2.04</h2>
+<? ficlVersion("Version 2.04") ?>
-<h3>
-ficlwin</h3>
+<h3>ficlwin</h3>
<ul>
<li>
Catches exceptions thrown by VM in ficlThread (0 @ for example) rather
-than passing them off to the OS.&nbsp;</li>
+than passing them off to the OS.&nbsp;
</ul>
<h3>
@@ -427,20 +640,20 @@ ficl bugs vanquished</h3>
<ul>
<li>
-Fixed leading delimiter bugs in s" ." .( and ( (reported by Reuben Thomas)</li>
+Fixed leading delimiter bugs in s" ." .( and ( (reported by Reuben Thomas)
<li>
-Makefile tabs restored (thanks to Michael Somos)</li>
+Makefile tabs restored (thanks to Michael Somos)
<li>
ABORT" now throws -2 per the DPANS (thanks to Daniel Sobral for sharp eyes
-again)&nbsp;</li>
+again)&nbsp;
<li>
-ficlExec does not print the prompt string unless (source-id == 0)</li>
+ficlExec does not print the prompt string unless (source-id == 0)
<li>
-Various fixes contributed by the FreeBSD team.</li>
+Various fixes contributed by the FreeBSD team.
</ul>
<h3>
@@ -451,128 +664,127 @@ ficl enhancements</h3>
Words.c: modified ficlCatch to use vmExecute and vmInnerLoop (request of
Daniel Sobral) Added vmPop and vmPush functions (by request of Lars Krueger
) in vm.c These are shortcuts to the param stack. (Use LVALUEtoCELL to
-get things into CELL form)&nbsp;</li>
+get things into CELL form)&nbsp;
<li>
Added function vmGetStringEx with a flag to specify whether or not to skip
-lead delimiters</li>
+lead delimiters
<li>
-Added non-std word: number?</li>
+Added non-std word: number?
<li>
-Added CORE EXT word AGAIN (by request of Reuben Thomas)&nbsp;</li>
+Added CORE EXT word AGAIN (by request of Reuben Thomas)&nbsp;
<li>
-Added double cell local (2local) support</li>
+Added double cell local (2local) support
<li>
Augmented Johns Hopkins local syntax so that locals whose names begin with
-char 2 are treated as 2locals (OK - it's goofy, but handy for OOP)</li>
+char 2 are treated as 2locals (OK - it's goofy, but handy for OOP)
<li>
-C-string class revised and enhanced - now dynamically sized</li>
+C-string class revised and enhanced - now dynamically sized
<li>
-C-hashstring class derived from c-string computes hashcode too.</li>
+C-hashstring class derived from c-string computes hashcode too.
</ul>
-</td>
-</tr>
-<tr>
-<td>
-<h2>
-Version 2.03</h2>
+
+<? ficlVersion("Version 2.03") ?>
+
This is the first version of Ficl that includes contributed code. Thanks
especially to Daniel Sobral, Michael Gauland for contributions and bug
-finding.&nbsp;
-<p>New words&nbsp;
+finding.
+<p>
+New words:
<ul>
<li>
<tt><a href="#clock">clock</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FICL)</tt></li>
+(FICL)</tt>
<li>
<tt><a href="#clockspersec">clocks/sec</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FICL)</tt></li>
+(FICL)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans8.htm#8.6.1.1230">dnegate</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(DOUBLE)</tt></li>
+(DOUBLE)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans10.htm#10.6.2.1905">ms</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FACILITY EXT - replaces MSEC <i>ficlWin only</i>)</tt></li>
+(FACILITY EXT - replaces MSEC <i>ficlWin only</i>)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans9.htm#9.6.1.2275">throw</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(EXCEPTION)</tt></li>
+(EXCEPTION)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans9.htm#9.6.1.0875">catch</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(EXCEPTION)</tt></li>
+(EXCEPTION)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.0707">allocate</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(MEMORY)</tt></li>
+(MEMORY)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.1605">free</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(MEMORY)</tt></li>
+(MEMORY)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans14.htm#14.6.1.2145">resize</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(MEMORY)</tt></li>
+(MEMORY)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans6.htm#6.2.2440">within</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(CORE EXT)</tt></li>
+(CORE EXT)</tt>
<li>
<tt><a href="#alloc">alloc</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(class method)</tt></li>
+(class method)</tt>
<li>
<tt><a href="#allocarray">alloc-array</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(class method)</tt></li>
+(class method)</tt>
<li>
<tt><a href="#oofree">free</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(class method)</tt></li>
+(class method)</tt>
</ul>
-Bugs Fixed&nbsp;
+
+Bugs Fixed:
<ul>
<li>
Bug fix in isNumber(): used to treat chars between 'Z' and 'a' as valid
-in base 10... (harmless, but weird)</li>
+in base 10... (harmless, but weird)
<li>
ficlExec pushes the <i>ip</i> and <tt>interpret</tt>s at the right times
-so that nested calls to ficlExec behave the way you'd expect them to.</li>
+so that nested calls to ficlExec behave the way you'd expect them to.
<li>
<tt>evaluate</tt> respects count parameter, and also passes exceptional
-return conditions back out to the calling instance of ficlExec.</li>
+return conditions back out to the calling instance of ficlExec.
<li>
-VM_QUIT now clears the locals dictionary in ficlExec.</li>
+VM_QUIT now clears the locals dictionary in ficlExec.
</ul>
Ficlwin Enhancements&nbsp;
<ul>
<li>
-File Menu: recent file list and Open now load files.</li>
+File Menu: recent file list and Open now load files.
<li>
Text ouput function is now faster through use of string caching. Cache
-flushes at the end of each line and each time ficlExec returns.</li>
+flushes at the end of each line and each time ficlExec returns.
<li>
Edit/paste now behaves more reasonably for text. File/open loads the specified
-file.</li>
+file.
<li>
Registry entries specify dictionary and stack sizes, default window placement,
-and whether or not to create a splitter for multiple VMs. See HKEY_CURRENT_USER/Software/CodeLab/ficlwin/Settings</li>
+and whether or not to create a splitter for multiple VMs. See HKEY_CURRENT_USER/Software/CodeLab/ficlwin/Settings
</ul>
Ficl Enhancements&nbsp;
<ul>
@@ -585,137 +797,134 @@ for INT32 and UNS32 in 32 bit versions, but a are obsolescent. Please use
the new data types instead. Typed stack operations on INT32 and UNS32 have
been renamed because they operate on CELL scalar types, which are 64 bits
wide on 64 bit systems. Added BITS_PER_CELL, which has legal values of
-32 or 64. Default is 32.</li>
+32 or 64. Default is 32.
<li>
ficl.c: Added ficlExecXT() - executes an xt completely before returning,
passing back any exception codes generated in the process. Normal exit
-code is VM_INNEREXIT.</li>
+code is VM_INNEREXIT.
<li>
ficl.c: Added ficlExecC() to operate on counted strings as opposed to zero
-terminated ones.</li>
+terminated ones.
<li>
ficlExec pushes ip and executes interpret at the right times so that nested
-calls to ficlExec behave the way you'd expect them to.</li>
+calls to ficlExec behave the way you'd expect them to.
<li>
ficlSetStackSize() allows specification of stack size at run-time (affects
-subsequent invocations of ficlNewVM()).</li>
+subsequent invocations of ficlNewVM()).
<li>
vm.c: vmThrow() checks for (pVM->pState != NULL) before longjmping it.
-vmCreate nulls this pointer initially.&nbsp;</li>
+vmCreate nulls this pointer initially.&nbsp;
<li>
-EXCEPTION wordset contributed by Daniel Sobral of FreeBSD</li>
+EXCEPTION wordset contributed by Daniel Sobral of FreeBSD
<li>
MEMORY-ALLOC wordset contributed by Daniel Sobral, too. Added class methods
<tt>alloc</tt>
and <tt>alloc-array</tt> in softwords/oo.fr to allocate objects from the
-heap.</li>
+heap.
<li>
Control structure match check upgraded (thanks to Daniel Sobral for this
suggestion). Control structure mismatches are now errors, not warnings,
-since the check accepts all syntactally legal constructs.</li>
+since the check accepts all syntactally legal constructs.
<li>
Added vmInnerLoop() to vm.h. This function/macro factors the inner&nbsp;
interpreter out of ficlExec so it can be used in other places. Function/macro
behavior is conditioned on INLINE_INNER_LOOP in sysdep.h. Default: 1 unless
_DEBUG is set. In part, this is because VC++ 5 goes apoplectic when trying
-to compile it as a function. See&nbsp;</li>
+to compile it as a function. See&nbsp;
<br>comments in vm.c
<li>
EVALUATE respects the count parameter, and also passes exceptional return
-conditions back out to the calling instance of ficlExec.</li>
+conditions back out to the calling instance of ficlExec.
<li>
-VM_QUIT clears locals dictionary in ficlExec()</li>
+VM_QUIT clears locals dictionary in ficlExec()
<li>
Added Michael Gauland's ficlLongMul and ficlLongDiv and support routines
to math64.c and .h. These routines are coded in C, and are compiled only
-if PORTABLE_LONGMULDIV == 1 (default is 0).</li>
+if PORTABLE_LONGMULDIV == 1 (default is 0).
<li>
Added definition of ficlRealloc to sysdep.c (needed for memory allocation
wordset). If your target OS supports realloc(), you'll probably want to
redefine ficlRealloc in those terms. The default version does ficlFree
-followed by ficlMalloc.</li>
+followed by ficlMalloc.
<li>
testmain.c: Changed gets() in testmain to fgets() to appease the security
-gods.</li>
+gods.
<li>
testmain: <tt>msec</tt> renamed to <tt><a href="#ficlms">ms</a></tt> in
-line with the ANS</li>
+line with the ANS
<li>
softcore.pl now removes comments &amp; spaces at the start and end of lines.
As a result: sizeof (softWords) == 7663 bytes (used to be 20000)&nbsp;
-and consumes 11384 bytes of dictionary when compiled</li>
+and consumes 11384 bytes of dictionary when compiled
<li>
-Deleted license paste-o in readme.txt (oops).</li>
+Deleted license paste-o in readme.txt (oops).
</ul>
-</td>
-</tr>
-<tr>
-<td>
-<h2>
-Version 2.02</h2>
-New words&nbsp;
+
+<? ficlVersion("Version 2.02") ?>
+
+New words:
<ul>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans6.htm#6.2.1850">marker</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(CORE EXT)</tt></li>
+(CORE EXT)</tt>
<li>
<tt><a href="http://www.taygeta.com/forth/dpans15.htm#15.6.2.1580">forget</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(TOOLS EXT)</tt></li>
+(TOOLS EXT)</tt>
<li>
<tt><a href="#ficlforgetwid">forget-wid</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FICL)</tt></li>
+(FICL)</tt>
<li>
-<tt><a href="#ficlwordlist">ficl-wordlist</a>&nbsp;&nbsp;&nbsp;&nbsp; (FICL)</tt></li>
+<tt><a href="#ficlwordlist">ficl-wordlist</a>&nbsp;&nbsp;&nbsp;&nbsp; (FICL)</tt>
<li>
-<tt><a href="#ficlvocabulary">ficl-vocabulary</a>&nbsp;&nbsp; (FICL)</tt></li>
+<tt><a href="#ficlvocabulary">ficl-vocabulary</a>&nbsp;&nbsp; (FICL)</tt>
<li>
<tt><a href="#ficlhide">hide</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FICL)</tt></li>
+(FICL)</tt>
<li>
<tt><a href="#ficlhidden">hidden</a>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
-(FICL)</tt></li>
+(FICL)</tt>
<li>
<a href="#jhlocal">Johns Hopkins local variable syntax</a> (as best I can
-determine)</li>
+determine)
</ul>
Bugs Fixed&nbsp;
<ul>
<li>
<tt>forget</tt> now adjusts the dictionary pointer to remove the name of
the word being forgotten (name chars come before the word header in ficl's
-dictionary)</li>
+dictionary)
<li>
<tt>:noname</tt> used to push the colon control marker and its execution
-token in the wrong order</li>
+token in the wrong order
<li>
-<tt>source-id</tt> now behaves correctly when loading a file.</li>
+<tt>source-id</tt> now behaves correctly when loading a file.
<li>
<tt>refill</tt> returns zero at EOF (Win32 load). Win32 <tt><a href="#ficlload">load</a></tt>
@@ -723,82 +932,72 @@ command continues to be misnamed. Really ought to be called <tt>included</tt>,
but does not exactly conform to that spec either (because <tt>included</tt>
expects a string signature on the stack, while Ficl's <tt><a href="#ficlload">load</a></tt>
expects a filename upon invocation). The "real" <tt>LOAD</tt> is a <tt>BLOCK</tt>
-word.</li>
+word.
</ul>
Enhancements (IMHO)&nbsp;
<ul>
<li>
-dictUnsmudge no longer links anonymous definitions into the dictionary</li>
+dictUnsmudge no longer links anonymous definitions into the dictionary
<li>
<tt>oop</tt> is no longer the default compile wordlist at startup, nor
is it in the search order. Execute <b><tt>also oop definitions</tt></b>
-to use Ficl OOP.</li>
+to use Ficl OOP.
<li>
-Revised oo.fr extensively to make more use of early binding</li>
+Revised oo.fr extensively to make more use of early binding
<li>
Added <tt>meta</tt> - a constant that pushes the address of metaclass.
-See oo.fr for examples of use.</li>
+See oo.fr for examples of use.
<li>
Added classes: <tt>c-ptr&nbsp; c-bytePtr&nbsp; c-2bytePtr&nbsp; c-cellPtr
</tt>These
classes model pointers to non-object data, but each knows the size of its
-referent.</li>
+referent.
</ul>
-</td>
-</tr>
-<tr>
-<td>
-<h2>
-Version 2.01</h2>
+
+<? ficlVersion("Version 2.01") ?>
<ul>
<li>
Bug fix: <tt>(local)</tt> used to leave a value on the stack between the
-first and last locals declared. This value is now stored in a static.</li>
+first and last locals declared. This value is now stored in a static.
<li>
Added new local syntax with parameter re-ordering. <a href="#newlocal">See
description below</a>. (No longer compiled in version 2.02, in favor of
-the Johns Hopkins syntax)</li>
+the Johns Hopkins syntax)
</ul>
-</td>
-</tr>
-<tr>
-<td>
-<h2>
-Version 2.0</h2>
+
+<? ficlVersion("Version 2.0") ?>
<ul>
<li>
New ANS Forth words: <tt>TOOLS</tt> and part of <tt>TOOLS EXT, SEARCH</tt>
and <tt>SEARCH EXT, LOCALS</tt> and <tt>LOCALS EXT</tt> word sets, additional
words from <tt>CORE EXT, DOUBLE</tt>, and <tt>STRING</tt>. (See the function
-ficlCompileCore in words.c for an alphabetical list by word set).</li>
+ficlCompileCore in words.c for an alphabetical list by word set).
<li>
Simple <tt>USER</tt> variable support - a user variable is a virtual machine
instance variable. User variables behave as <tt>VARIABLE</tt>s in all other
-respects.</li>
+respects.
<li>
-Object oriented syntax extensions (see below)</li>
+Object oriented syntax extensions (see below)
<li>
Optional stack underflow and overflow checking in many CORE words (enabled
-when FICL_ROBUST >= 2)</li>
+when FICL_ROBUST >= 2)
<li>
-Various bug fixes</li>
+Various bug fixes
</ul>
-</td>
-</tr>
-</table>
-</body>
-</html>
+
+
+<? ficlPageFooter() ?>
diff --git a/doc/source/upgrading.ht b/doc/source/upgrading.ht
new file mode 100644
index 000000000000..9d9b5f26a022
--- /dev/null
+++ b/doc/source/upgrading.ht
@@ -0,0 +1,349 @@
+<?
+
+ficlPageHeader("upgrading ficl")
+
+ficlAddToNavBarAs("Upgrading To 4.0")
+
+def startoldvsnew(extra = None):
+ print "<table width=100%><tr>\n"
+ print "<td bgcolor=#d0d0f0><b>old name</b></td>\n"
+ print "<td bgcolor=#e0e0ff><b>new name</td>\n"
+ if extra != None:
+ print "<td bgcolor=#d0d0f0><b>" + extra + "</td>\n"
+ print "</tr>\n"
+
+def oldvsnew(old, new, extra = None):
+ print "<tr>\n"
+ print "<td bgcolor=#e0e0e0><code>" + old + "</code></td>\n"
+ print "<td bgcolor=#f0f0f0><code>" + new + "</code></td>\n"
+ if extra != None:
+ print "<td bgcolor=#e0e0e0><code>" + extra + "</code></td>\n"
+ print"</tr>\n\n"
+
+
+def endoldvsnew():
+ print "</table><p>\n"
+
+?>
+
+Ficl 4.0 is smaller, faster, and more capable than any previous
+version. For more information on why Ficl 4.0 is so gosh-darned
+swell, see the <a href=index.html#WhatsNewInFicl4.0>What's New In Ficl 4.0?</a>
+section of the overview.
+<p>
+
+
+Since the Ficl API has changed so dramatically, you can't just drop
+the new Ficl source. You have two basic choices:
+<a href=#compatibility>use the <code>FICL_WANT_COMPATIBILITY</code> support</a>, and
+<a href=#newapi>switching to the new API</a>.
+<p>
+
+Note that using <i>either</i> of these choices <i>requires</i>
+that you recompile your application. You cannot build Ficl 4 into
+a shared library or DLL and use it with an application expecting
+Ficl 3.0. Stated another way: Ficl 4 is <i>source</i> compatible
+but not <i>binary</i> compatible with Ficl 3.
+
+
+<a name=oldnames>
+<? ficlHeader1("Using <code>FICL_WANT_COMPATIBILITY</code>") ?>
+</a>
+
+
+If you want to get Ficl 4.0 up and running in your project as quickly
+as possible, <code>FICL_WANT_COMPATIBILITY</code> is what you'll want to use.
+There are two easy steps, one of which you might be able to skip:
+<p>
+
+<ol>
+
+<li>
+Set the C preprocessor constant <code>FICL_WANT_COMPATIBILITY</code> to 1.
+The best way is by adding the following line to <code>ficllocal.h</code>:
+<pre>
+ #define FICL_WANT_COMPATIBILITY (1)
+</pre>
+
+
+<li>
+
+<i>If</i> you use a custom <code>ficlTextOut()</code> function, you'll
+have to rename it, and explicitly specify it to Ficl. Renaming it is
+necessary, because the Ficl compatibility layer also provides one for
+code that called <code>ficlTextOut()</code> directly (instead of calling
+<code>vmTextOut()</code> as it should have).
+We recommend renaming your function to <code>ficlTextOutLocal()</code>, as
+we have have provided a prototype for this function for you in <code>ficlcompatibility.h</code>.
+This will save you the trouble of defining your own prototype, ensuring you get
+correct name decoration / linkage, etc.
+
+<p>
+
+There are two methods you can use to specify your <code>ficlTextOut()</code>
+function:
+<ol>
+
+<li>
+Specify it in the <code>FICL_INIT_INFO</code> structure passed in to
+<code>ficlInitSystem()</code>. This is the preferred method, as it ensures
+you will see the results of Ficl's initialization code, and it will be
+automatically passed in to every newly created VM.
+
+<li>
+Set it explicitly in every VM by calling <code>vmSetTextOut()</code> and
+passing it in.
+
+</ol>
+<p>
+
+<b>Note:</b> Any other method, such as setting it by hand in the
+<code>FICL_SYSTEM</code> or <code>FICL_VM</code> structures,
+will <b>not</b> work. There is a special compatibility layer for old-style
+<code>OUTFUNC</code> functions, but it is only invoked properly when you
+use one of the two methods mentioned above.
+
+
+</ol>
+
+<p>
+
+This <i>should</i> be sufficient for you to recompile-and-go
+with Ficl 4. If it's not, please let us know, preferably including a
+suggested solution to the problem.
+
+
+<a name=newapi>
+<? ficlHeader1("Using The New API") ?>
+</a>
+
+Since most (all?) of the external symbols have changed names since the 3.0 series,
+here is a quick guide to get you started on renaming everything. This is by no
+means an exhaustive list; this is meant to guide you towards figuring out what
+the new name <i>should</i> be. (After all, part of the point of this massive
+renaming was to make all the external symbols consistent.)
+<p>
+
+
+
+
+<? ficlHeader2("Types") ?>
+
+Every external type has been renamed. They all begin with the
+word <code>ficl</code>, and they use mixed case (instead of all upper-case,
+which is now reserved for macros). Also, the confusingly-named
+string objects have been renamed:
+<code>FICL_STRING</code> is now <code>ficlCountedString</code>, as it
+represents a "counted string" in the language, and
+the more commonly-used <code>STRINGINFO</code> is now simply
+<code>ficlString</code>.
+
+<?
+
+startoldvsnew()
+
+oldvsnew("FICL_SYSTEM", "ficlSystem")
+oldvsnew("FICL_VM", "ficlVm")
+oldvsnew("FICL_SYSTEM_INFO", "ficlSystemInformation")
+oldvsnew("FICL_WORD", "ficlWord")
+oldvsnew("IPTYPE", "ficlIp")
+oldvsnew("FICL_CODE", "ficlPrimitive")
+oldvsnew("OUTFUNC", "ficlOutputFunction")
+oldvsnew("FICL_DICTIONARY", "ficlDictionary")
+oldvsnew("FICL_STACK", "ficlStack")
+oldvsnew("STRINGINFO", "ficlString")
+oldvsnew("FICL_STRING", "ficlCountedString")
+
+endoldvsnew()
+
+?>
+
+<? ficlHeader2("Structure Members") ?>
+
+In addition, many structure names have changed. To help ease the heartache,
+we've also added some accessor macros. So, in case they change in the future,
+your code might still compile (hooray!).
+<?
+
+startoldvsnew("accessor")
+
+oldvsnew("pExtend", "context", "ficlVmGetContext(), ficlSystemGetContext()")
+oldvsnew("pStack", "dataStack", "ficlVmGetDataStack()")
+oldvsnew("fStack", "floatStack", "ficlVmGetFloatStack()")
+oldvsnew("rStack", "returnStack", "ficlVmGetReturnStack()")
+
+endoldvsnew()
+
+?>
+
+<? ficlHeader2("Callback Functions") ?>
+
+Text output callbacks have changed in two major ways:
+
+<ul>
+
+<li>
+They no longer take a VM pointer; they now take a <code>ficlCallback</code> structure.
+This allows output to be printed before a VM is defined, or in circumstances where a
+VM may not be defined (such as an assertion failure in a <code>ficlSystem...()</code> function).
+
+<li>
+They no longer take a flag indicating whether or not to add a "newline".
+Instead, the function must output a newline whenever it encounters
+a <code>\n</code> character in the text.
+
+</ul>
+
+If you don't want to rewrite your output function yet, you can
+"thunk" the new-style call to the old-style. Just pass in <code>ficlOldnamesCallbackTextOut</code>
+as the name of the output function for the system and VM, and then set
+the <code>thunkedTextout</code> member of the <code>ficlSystem</code>
+or <code>ficlVm</code> to your old-style text output function.
+
+
+<? ficlHeader2("Renamed Macros") ?>
+
+<?
+
+startoldvsnew()
+
+oldvsnew("PUSHPTR(p)", "ficlStackPushPointer(vm->dataStack, p)")
+oldvsnew("POPUNS()", "ficlStackPopUnsigned(vm->dataStack)")
+oldvsnew("GETTOP()", "ficlStackGetTop(vm->dataStack)")
+
+oldvsnew("FW_IMMEDIATE", "FICL_WORD_IMMEDIATE")
+oldvsnew("FW_COMPILE", "FICL_WORD_COMPILE_ONLY")
+
+oldvsnew("VM_INNEREXIT", "FICL_VM_STATUS_INNER_EXIT")
+oldvsnew("VM_OUTOFTEXT", "FICL_VM_STATUS_OUT_OF_TEXT")
+oldvsnew("VM_RESTART", "FICL_VM_RESTART")
+
+
+endoldvsnew()
+
+?>
+
+<? ficlHeader2("<code>ficllocal.h</code>") ?>
+
+One more note about macros. Ficl now ships with a standard place for
+you to tweak the Ficl compile-time preprocessor switches such as
+<code>FICL_WANT_COMPATIBILITY</code> and <code>FICL_WANT_FLOAT</code>.
+It's a file called <code>ficllocal.h</code>, and we guarantee that it
+will always ship empty (or with only comments). We suggest that you
+put all your local changes there, rather than editing <code>ficl.h</code>
+or editing the makefile. That should make it much easier to integrate
+future Ficl releases into your product&mdash;all you need do is preserve
+your tweaked copy of <code>ficllocal.h</code> and replace the rest.
+
+
+<? ficlHeader2("Renamed Functions") ?>
+
+Every function that deals primarily with a particular structure
+is now named after that structure. For instance, any function
+that takes a <code>ficlSystem</code> as its first argument is
+named <code>ficlSystem<i>Something</i>()</code>. Any function
+that takes a <code>ficlVm</code> as its first argument is
+named <code>ficlVm<i>Something</i>()</code>. And so on.
+<p>
+
+Also, functions that create a new object are always
+called <code>Create</code> (not <code>Alloc</code>, <code>Allot</code>, <code>Init</code>, or <code>New</code>).
+Functions that create a new object are always
+called <code>Destroy</code> (not <code>Free</code>, <code>Term</code>, or <code>Delete</code>).
+<p>
+
+
+<?
+
+startoldvsnew()
+
+oldvsnew("ficlInitSystem()", "ficlSystemCreate()")
+oldvsnew("ficlTermSystem()", "ficlSystemDestroy()")
+oldvsnew("ficlNewVM()", "ficlSystemCreateVm()")
+oldvsnew("ficlFreeVM()", "ficlVmDestroy()")
+oldvsnew("dictCreate()", "ficlDictionaryCreate()")
+oldvsnew("dictDelete()", "ficlDictionaryDestroy()")
+
+endoldvsnew()
+
+?>
+<p>
+
+All functions exported by Ficl now start with the word <code>ficl</code>.
+This is a <i>feature</i>, as it means the Ficl project will no longer
+pollute your namespace.
+
+<?
+
+startoldvsnew()
+
+oldvsnew("PUSHPTR(p)", "ficlStackPushPointer(vm->dataStack, p)")
+oldvsnew("POPUNS()", "ficlStackPopUnsigned(vm->dataStack)")
+oldvsnew("GETTOP()", "ficlStackGetTop(vm->dataStack)")
+oldvsnew("ltoa()", "ficlLtoa()")
+oldvsnew("strincmp()", "ficlStrincomp()")
+
+endoldvsnew()
+
+?>
+
+
+
+<? ficlHeader2("Removed Functions") ?>
+
+A few entry points have simply been removed.
+For instance, functions specifically managing a system's <code>ENVIRONMENT</code>
+settings have been removed, in favor of managing the system's
+<code>environment</code> dictionary directly:
+<?
+
+startoldvsnew()
+
+oldvsnew("ficlSystemSetEnvironment(system)", "ficlDictionarySetConstant(ficlSystemGetEnvironment(system), ...)")
+oldvsnew("ficlSystemSet2Environment(system)", "ficlDictionarySet2Constant(ficlSystemGetEnvironment(system), ...)")
+
+endoldvsnew()
+
+?>
+
+
+In a similar vein, <code>ficlSystemBuild()</code> has been removed in favor
+of using <code>ficlDictionarySetPrimitive()</code> directly:
+
+<?
+startoldvsnew()
+oldvsnew("ficlSystemBuild(system, ...)", "ficlDictionarySetPrimitive(ficlSystemGetDictionary(system), ...)")
+endoldvsnew()
+?>
+
+Finally, there is no <i>exact</i> replacement for <code>ficlExec()</code>. 99% of the code
+that called <code>ficlExec()</code> never bothered to manage <code>SOURCE-ID</code> properly.
+If you were calling <code>ficlExec()</code>, and you weren't changing <code>SOURCE-ID</code>
+(or <code>vm->sourceId</code>) to match, you should replace those calls with <code>ficlVmEvaluate()</code>,
+which will manage <code>SOURCE-ID</code> for you.
+<p>
+
+There <i>is</i> a function that takes the place of <code>ficlExec()</code> which doesn't change
+<code>SOURCE-ID</code>: <code>ficlVmExecuteString()</code>. However, instead of taking a
+straight C string (a <code>char *</code>), it takes a <code>ficlString *</code> as its
+code argument. (This is to discourage its use.)
+
+
+<?
+ficlHeader1("Internal Changes")
+?>
+
+<b>Note:</b> none of these changes should affect you. If they do, there's probably
+a problem somewhere. Either Ficl's API doesn't abstract away something enough, or
+you are approaching a problem the wrong way. Food for thought.
+<p>
+
+There's only one internal change worth noting here.
+The top value on a Ficl stack used to be at (to use the modern structure names)
+<code>stack->top[-1]</code>. It is now at <code>stack->top[0]</code>.
+In other words, the "stack top" pointer used to point <i>past</i> the top
+element; it now points <i>at</i> the top element. (Pointing <i>at</i> the
+top element is not only less confusing, it is also faster.)
+
+</body>
+</html>
diff --git a/doc/upgrading.html b/doc/upgrading.html
new file mode 100644
index 000000000000..7ebde0568984
--- /dev/null
+++ b/doc/upgrading.html
@@ -0,0 +1,808 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<HTML>
+<HEAD>
+<META name='Description' content='Ficl - embedded scripting with object oriented programming'>
+<META name='Keywords' content='scripting prototyping tcl OOP Forth interpreter C'>
+<LINK rel='SHORTCUT ICON' href='ficl.ico'>
+<TITLE>upgrading ficl</TITLE>
+<style>
+
+blockquote { margin-left: 1em }
+
+</style>
+
+</HEAD>
+<BODY>
+
+<table border=0 cellspacing=0 width=100%%><tr>
+
+
+<td width=112 bgcolor=#004968 colspan=3>
+<img src=graphics/ficl.4.96.jpg height=96 width=96>
+</td>
+
+<td bgcolor=#004968>
+<font face=arial,helvetica color=white size=7><b><i>
+upgrading ficl
+</i></b></font>
+</td></tr>
+
+
+<tr>
+<td bgcolor=#004968 width=10></td>
+<td bgcolor=#004968 valign=top>
+<br><p>
+<a href=index.html><font face=arial,helvetica color=white><b>Index</b></font></a><p>
+<p><br>
+<a href=dpans.html><font face=arial,helvetica color=white><b>ANS</b></font></a><br>
+<a href=api.html><font face=arial,helvetica color=white><b>API</b></font></a><br>
+<a href=debugger.html><font face=arial,helvetica color=white><b>Debugger</b></font></a><br>
+<a href=http://sourceforge.net/project/showfiles.php?group_id=24441><font face=arial,helvetica color=white><b>Download</b></font></a><br>
+<a href=license.html><font face=arial,helvetica color=white><b>Licensing</b></font></a><br>
+<a href=links.html><font face=arial,helvetica color=white><b>Links</b></font></a><br>
+<a href=locals.html><font face=arial,helvetica color=white><b>Locals</b></font></a><br>
+<a href=oop.html><font face=arial,helvetica color=white><b>OOP&nbsp;In&nbsp;Ficl</b></font></a><br>
+<a href=parsesteps.html><font face=arial,helvetica color=white><b>Parse&nbsp;Steps</b></font></a><br>
+<a href=releases.html><font face=arial,helvetica color=white><b>Release&nbsp;History</b></font></a><br>
+<a href=upgrading.html><font face=arial,helvetica color=white><b>Upgrading&nbsp;To&nbsp;4.0</b></font></a><br>
+</td><td bgcolor=#004968 width=5></td><td valign=top><blockquote><p>
+
+
+
+Ficl 4.0 is smaller, faster, and more capable than any previous
+version. For more information on why Ficl 4.0 is so gosh-darned
+swell, see the <a href=index.html#WhatsNewInFicl4.0>What's New In Ficl 4.0?</a>
+section of the overview.
+<p>
+
+
+Since the Ficl API has changed so dramatically, you can't just drop
+the new Ficl source. You have two basic choices:
+<a href=#compatibility>use the <code>FICL_WANT_COMPATIBILITY</code> support</a>, and
+<a href=#newapi>switching to the new API</a>.
+<p>
+
+Note that using <i>either</i> of these choices <i>requires</i>
+that you recompile your application. You cannot build Ficl 4 into
+a shared library or DLL and use it with an application expecting
+Ficl 3.0. Stated another way: Ficl 4 is <i>source</i> compatible
+but not <i>binary</i> compatible with Ficl 3.
+
+
+<a name=oldnames>
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='UsingcodeFICL_WANT_COMPATIBILITY/code'>
+Using <code>FICL_WANT_COMPATIBILITY</code>
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+</a>
+
+
+If you want to get Ficl 4.0 up and running in your project as quickly
+as possible, <code>FICL_WANT_COMPATIBILITY</code> is what you'll want to use.
+There are two easy steps, one of which you might be able to skip:
+<p>
+
+<ol>
+
+<li>
+Set the C preprocessor constant <code>FICL_WANT_COMPATIBILITY</code> to 1.
+The best way is by adding the following line to <code>ficllocal.h</code>:
+<pre>
+ #define FICL_WANT_COMPATIBILITY (1)
+</pre>
+
+
+<li>
+
+<i>If</i> you use a custom <code>ficlTextOut()</code> function, you'll
+have to rename it, and explicitly specify it to Ficl. Renaming it is
+necessary, because the Ficl compatibility layer also provides one for
+code that called <code>ficlTextOut()</code> directly (instead of calling
+<code>vmTextOut()</code> as it should have).
+We recommend renaming your function to <code>ficlTextOutLocal()</code>, as
+we have have provided a prototype for this function for you in <code>ficlcompatibility.h</code>.
+This will save you the trouble of defining your own prototype, ensuring you get
+correct name decoration / linkage, etc.
+
+<p>
+
+There are two methods you can use to specify your <code>ficlTextOut()</code>
+function:
+<ol>
+
+<li>
+Specify it in the <code>FICL_INIT_INFO</code> structure passed in to
+<code>ficlInitSystem()</code>. This is the preferred method, as it ensures
+you will see the results of Ficl's initialization code, and it will be
+automatically passed in to every newly created VM.
+
+<li>
+Set it explicitly in every VM by calling <code>vmSetTextOut()</code> and
+passing it in.
+
+</ol>
+<p>
+
+<b>Note:</b> Any other method, such as setting it by hand in the
+<code>FICL_SYSTEM</code> or <code>FICL_VM</code> structures,
+will <b>not</b> work. There is a special compatibility layer for old-style
+<code>OUTFUNC</code> functions, but it is only invoked properly when you
+use one of the two methods mentioned above.
+
+
+</ol>
+
+<p>
+
+This <i>should</i> be sufficient for you to recompile-and-go
+with Ficl 4. If it's not, please let us know, preferably including a
+suggested solution to the problem.
+
+
+<a name=newapi>
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='UsingTheNewAPI'>
+Using The New API
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+</a>
+
+Since most (all?) of the external symbols have changed names since the 3.0 series,
+here is a quick guide to get you started on renaming everything. This is by no
+means an exhaustive list; this is meant to guide you towards figuring out what
+the new name <i>should</i> be. (After all, part of the point of this massive
+renaming was to make all the external symbols consistent.)
+<p>
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='Types'>
+Types
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Every external type has been renamed. They all begin with the
+word <code>ficl</code>, and they use mixed case (instead of all upper-case,
+which is now reserved for macros). Also, the confusingly-named
+string objects have been renamed:
+<code>FICL_STRING</code> is now <code>ficlCountedString</code>, as it
+represents a "counted string" in the language, and
+the more commonly-used <code>STRINGINFO</code> is now simply
+<code>ficlString</code>.
+
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_SYSTEM</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlSystem</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_VM</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlVm</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_SYSTEM_INFO</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlSystemInformation</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_WORD</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlWord</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>IPTYPE</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlIp</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_CODE</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlPrimitive</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>OUTFUNC</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlOutputFunction</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_DICTIONARY</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionary</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_STACK</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStack</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>STRINGINFO</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlString</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FICL_STRING</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlCountedString</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='StructureMembers'>
+Structure Members
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+In addition, many structure names have changed. To help ease the heartache,
+we've also added some accessor macros. So, in case they change in the future,
+your code might still compile (hooray!).
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+<td bgcolor=#d0d0f0><b>accessor</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>pExtend</code></td>
+
+<td bgcolor=#f0f0f0><code>context</code></td>
+
+<td bgcolor=#e0e0e0><code>ficlVmGetContext(), ficlSystemGetContext()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>pStack</code></td>
+
+<td bgcolor=#f0f0f0><code>dataStack</code></td>
+
+<td bgcolor=#e0e0e0><code>ficlVmGetDataStack()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>fStack</code></td>
+
+<td bgcolor=#f0f0f0><code>floatStack</code></td>
+
+<td bgcolor=#e0e0e0><code>ficlVmGetFloatStack()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>rStack</code></td>
+
+<td bgcolor=#f0f0f0><code>returnStack</code></td>
+
+<td bgcolor=#e0e0e0><code>ficlVmGetReturnStack()</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='CallbackFunctions'>
+Callback Functions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Text output callbacks have changed in two major ways:
+
+<ul>
+
+<li>
+They no longer take a VM pointer; they now take a <code>ficlCallback</code> structure.
+This allows output to be printed before a VM is defined, or in circumstances where a
+VM may not be defined (such as an assertion failure in a <code>ficlSystem...()</code> function).
+
+<li>
+They no longer take a flag indicating whether or not to add a "newline".
+Instead, the function must output a newline whenever it encounters
+a <code>\n</code> character in the text.
+
+</ul>
+
+If you don't want to rewrite your output function yet, you can
+"thunk" the new-style call to the old-style. Just pass in <code>ficlOldnamesCallbackTextOut</code>
+as the name of the output function for the system and VM, and then set
+the <code>thunkedTextout</code> member of the <code>ficlSystem</code>
+or <code>ficlVm</code> to your old-style text output function.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='RenamedMacros'>
+Renamed Macros
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>PUSHPTR(p)</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackPushPointer(vm->dataStack, p)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>POPUNS()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackPopUnsigned(vm->dataStack)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>GETTOP()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackGetTop(vm->dataStack)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FW_IMMEDIATE</code></td>
+
+<td bgcolor=#f0f0f0><code>FICL_WORD_IMMEDIATE</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>FW_COMPILE</code></td>
+
+<td bgcolor=#f0f0f0><code>FICL_WORD_COMPILE_ONLY</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>VM_INNEREXIT</code></td>
+
+<td bgcolor=#f0f0f0><code>FICL_VM_STATUS_INNER_EXIT</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>VM_OUTOFTEXT</code></td>
+
+<td bgcolor=#f0f0f0><code>FICL_VM_STATUS_OUT_OF_TEXT</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>VM_RESTART</code></td>
+
+<td bgcolor=#f0f0f0><code>FICL_VM_RESTART</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='codeficllocalh/code'>
+<code>ficllocal.h</code>
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+One more note about macros. Ficl now ships with a standard place for
+you to tweak the Ficl compile-time preprocessor switches such as
+<code>FICL_WANT_COMPATIBILITY</code> and <code>FICL_WANT_FLOAT</code>.
+It's a file called <code>ficllocal.h</code>, and we guarantee that it
+will always ship empty (or with only comments). We suggest that you
+put all your local changes there, rather than editing <code>ficl.h</code>
+or editing the makefile. That should make it much easier to integrate
+future Ficl releases into your product&mdash;all you need do is preserve
+your tweaked copy of <code>ficllocal.h</code> and replace the rest.
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='RenamedFunctions'>
+Renamed Functions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+Every function that deals primarily with a particular structure
+is now named after that structure. For instance, any function
+that takes a <code>ficlSystem</code> as its first argument is
+named <code>ficlSystem<i>Something</i>()</code>. Any function
+that takes a <code>ficlVm</code> as its first argument is
+named <code>ficlVm<i>Something</i>()</code>. And so on.
+<p>
+
+Also, functions that create a new object are always
+called <code>Create</code> (not <code>Alloc</code>, <code>Allot</code>, <code>Init</code>, or <code>New</code>).
+Functions that create a new object are always
+called <code>Destroy</code> (not <code>Free</code>, <code>Term</code>, or <code>Delete</code>).
+<p>
+
+
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlInitSystem()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlSystemCreate()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlTermSystem()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlSystemDestroy()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlNewVM()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlSystemCreateVm()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlFreeVM()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlVmDestroy()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>dictCreate()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionaryCreate()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>dictDelete()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionaryDestroy()</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+<p>
+
+All functions exported by Ficl now start with the word <code>ficl</code>.
+This is a <i>feature</i>, as it means the Ficl project will no longer
+pollute your namespace.
+
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>PUSHPTR(p)</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackPushPointer(vm->dataStack, p)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>POPUNS()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackPopUnsigned(vm->dataStack)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>GETTOP()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStackGetTop(vm->dataStack)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ltoa()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlLtoa()</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>strincmp()</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlStrincomp()</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#b8b8b8 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=4><b><i>
+<a name='RemovedFunctions'>
+Removed Functions
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+A few entry points have simply been removed.
+For instance, functions specifically managing a system's <code>ENVIRONMENT</code>
+settings have been removed, in favor of managing the system's
+<code>environment</code> dictionary directly:
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlSystemSetEnvironment(system)</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionarySetConstant(ficlSystemGetEnvironment(system), ...)</code></td>
+
+</tr>
+
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlSystemSet2Environment(system)</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionarySet2Constant(ficlSystemGetEnvironment(system), ...)</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+
+In a similar vein, <code>ficlSystemBuild()</code> has been removed in favor
+of using <code>ficlDictionarySetPrimitive()</code> directly:
+
+<table width=100%><tr>
+
+<td bgcolor=#d0d0f0><b>old name</b></td>
+
+<td bgcolor=#e0e0ff><b>new name</td>
+
+</tr>
+
+<tr>
+
+<td bgcolor=#e0e0e0><code>ficlSystemBuild(system, ...)</code></td>
+
+<td bgcolor=#f0f0f0><code>ficlDictionarySetPrimitive(ficlSystemGetDictionary(system), ...)</code></td>
+
+</tr>
+
+
+</table><p>
+
+
+
+Finally, there is no <i>exact</i> replacement for <code>ficlExec()</code>. 99% of the code
+that called <code>ficlExec()</code> never bothered to manage <code>SOURCE-ID</code> properly.
+If you were calling <code>ficlExec()</code>, and you weren't changing <code>SOURCE-ID</code>
+(or <code>vm->sourceId</code>) to match, you should replace those calls with <code>ficlVmEvaluate()</code>,
+which will manage <code>SOURCE-ID</code> for you.
+<p>
+
+There <i>is</i> a function that takes the place of <code>ficlExec()</code> which doesn't change
+<code>SOURCE-ID</code>: <code>ficlVmExecuteString()</code>. However, instead of taking a
+straight C string (a <code>char *</code>), it takes a <code>ficlString *</code> as its
+code argument. (This is to discourage its use.)
+
+
+
+<p>
+</blockquote><table border=0 bgcolor=#a0a0a0 width=100%><tr>
+
+<td width=1em></td>
+<td>
+<font face=arial,helvetica color=#004968 size=5><b><i>
+<a name='InternalChanges'>
+Internal Changes
+</a></i></b></font></td></tr></table><p><blockquote>
+
+
+
+<b>Note:</b> none of these changes should affect you. If they do, there's probably
+a problem somewhere. Either Ficl's API doesn't abstract away something enough, or
+you are approaching a problem the wrong way. Food for thought.
+<p>
+
+There's only one internal change worth noting here.
+The top value on a Ficl stack used to be at (to use the modern structure names)
+<code>stack->top[-1]</code>. It is now at <code>stack->top[0]</code>.
+In other words, the "stack top" pointer used to point <i>past</i> the top
+element; it now points <i>at</i> the top element. (Pointing <i>at</i> the
+top element is not only less confusing, it is also faster.)
+
+</body>
+</html>
diff --git a/double.c b/double.c
new file mode 100644
index 000000000000..805de3742fd4
--- /dev/null
+++ b/double.c
@@ -0,0 +1,479 @@
+/*******************************************************************
+** m a t h 6 4 . c
+** Forth Inspired Command Language - 64 bit math support routines
+** Authors: Michael A. Gauland (gaulandm@mdhost.cse.tek.com)
+** Larry Hastings (larry@hastings.org)
+** John Sadler (john_sadler@alum.mit.edu)
+** Created: 25 January 1998
+** Rev 2.03: Support for 128 bit DP math. This file really ouught to
+** be renamed!
+** $Id: double.c,v 1.2 2010/09/12 15:18:07 asau Exp $
+*******************************************************************/
+/*
+** 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
+** 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 <stdint.h>
+
+#include "ficl.h"
+
+
+#if FICL_PLATFORM_HAS_2INTEGER
+
+
+
+ficl2UnsignedQR ficl2UnsignedDivide(ficl2Unsigned q, ficlUnsigned y)
+{
+ ficl2UnsignedQR result;
+
+ result.quotient = q / y;
+ /*
+ ** Once we have the quotient, it's cheaper to calculate the
+ ** remainder this way than with % (mod). --lch
+ */
+ result.remainder = (ficlInteger)(q - (result.quotient * y));
+
+ return result;
+}
+
+
+#else /* FICL_PLATFORM_HAS_2INTEGER */
+
+
+#define FICL_CELL_HIGH_BIT ((uintmax_t)1 << (FICL_BITS_PER_CELL-1))
+#define UMOD_SHIFT (FICL_BITS_PER_CELL / 2)
+#define UMOD_MASK ((1L << (FICL_BITS_PER_CELL / 2)) - 1)
+
+
+/**************************************************************************
+ ficl2IntegerIsNegative
+** Returns TRUE if the specified ficl2Unsigned has its sign bit set.
+**************************************************************************/
+int ficl2IntegerIsNegative(ficl2Integer x)
+{
+ return (x.high < 0);
+}
+
+
+/**************************************************************************
+ ficl2IntegerNegate
+** Negates an ficl2Unsigned by complementing and incrementing.
+**************************************************************************/
+ficl2Integer ficl2IntegerNegate(ficl2Integer x)
+{
+ x.high = ~x.high;
+ x.low = ~x.low;
+ x.low ++;
+ if (x.low == 0)
+ x.high++;
+
+ return x;
+}
+
+/**************************************************************************
+ ficl2UnsignedMultiplyAccumulate
+** Mixed precision multiply and accumulate primitive for number building.
+** Multiplies ficl2Unsigned u by ficlUnsigned mul and adds ficlUnsigned add. Mul is typically
+** the numeric base, and add represents a digit to be appended to the
+** growing number.
+** Returns the result of the operation
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedMultiplyAccumulate(ficl2Unsigned u, ficlUnsigned mul, ficlUnsigned add)
+{
+ ficl2Unsigned resultLo = ficl2UnsignedMultiply(u.low, mul);
+ ficl2Unsigned resultHi = ficl2UnsignedMultiply(u.high, mul);
+ resultLo.high += resultHi.low;
+ resultHi.low = resultLo.low + add;
+
+ if (resultHi.low < resultLo.low)
+ resultLo.high++;
+
+ resultLo.low = resultHi.low;
+
+ return resultLo;
+}
+
+
+/**************************************************************************
+ ficl2IntegerMultiply
+** Multiplies a pair of ficlIntegers and returns an ficl2Integer result.
+**************************************************************************/
+ficl2Integer ficl2IntegerMultiply(ficlInteger x, ficlInteger y)
+{
+ ficl2Unsigned prod;
+ int sign = 1;
+
+ if (x < 0)
+ {
+ sign = -sign;
+ x = -x;
+ }
+
+ if (y < 0)
+ {
+ sign = -sign;
+ y = -y;
+ }
+
+ prod = ficl2UnsignedMultiply(x, y);
+ if (sign > 0)
+ return FICL_2UNSIGNED_TO_2INTEGER(prod);
+ else
+ return ficl2IntegerNegate(FICL_2UNSIGNED_TO_2INTEGER(prod));
+}
+
+
+
+ficl2Integer ficl2IntegerDecrement(ficl2Integer x)
+{
+ if (x.low == INT_MIN)
+ x.high--;
+ x.low--;
+
+ return x;
+}
+
+
+ficl2Unsigned ficl2UnsignedAdd(ficl2Unsigned x, ficl2Unsigned y)
+{
+ ficl2Unsigned result;
+ int carry;
+
+ result.high = x.high + y.high;
+ result.low = x.low + y.low;
+
+
+ carry = ((x.low | y.low) & FICL_CELL_HIGH_BIT) && !(result.low & FICL_CELL_HIGH_BIT);
+ carry |= ((x.low & y.low) & FICL_CELL_HIGH_BIT);
+
+ if (carry)
+ {
+ result.high++;
+ }
+
+ return result;
+}
+
+/**************************************************************************
+ ficl2UnsignedMultiply
+** Contributed by:
+** Michael A. Gauland gaulandm@mdhost.cse.tek.com
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedMultiply(ficlUnsigned x, ficlUnsigned y)
+{
+ ficl2Unsigned result = { 0, 0 };
+ ficl2Unsigned addend;
+
+ addend.low = y;
+ addend.high = 0; /* No sign extension--arguments are unsigned */
+
+ while (x != 0)
+ {
+ if ( x & 1)
+ {
+ result = ficl2UnsignedAdd(result, addend);
+ }
+ x >>= 1;
+ addend = ficl2UnsignedArithmeticShiftLeft(addend);
+ }
+ return result;
+}
+
+
+
+/**************************************************************************
+ ficl2UnsignedSubtract
+**
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedSubtract(ficl2Unsigned x, ficl2Unsigned y)
+{
+ ficl2Unsigned result;
+
+ result.high = x.high - y.high;
+ result.low = x.low - y.low;
+
+ if (x.low < y.low)
+ {
+ result.high--;
+ }
+
+ return result;
+}
+
+
+/**************************************************************************
+ ficl2UnsignedArithmeticShiftLeft
+** 64 bit left shift
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedArithmeticShiftLeft( ficl2Unsigned x )
+{
+ ficl2Unsigned result;
+
+ result.high = x.high << 1;
+ if (x.low & FICL_CELL_HIGH_BIT)
+ {
+ result.high++;
+ }
+
+ result.low = x.low << 1;
+
+ return result;
+}
+
+
+/**************************************************************************
+ ficl2UnsignedArithmeticShiftRight
+** 64 bit right shift (unsigned - no sign extend)
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedArithmeticShiftRight( ficl2Unsigned x )
+{
+ ficl2Unsigned result;
+
+ result.low = x.low >> 1;
+ if (x.high & 1)
+ {
+ result.low |= FICL_CELL_HIGH_BIT;
+ }
+
+ result.high = x.high >> 1;
+ return result;
+}
+
+
+/**************************************************************************
+ ficl2UnsignedOr
+** 64 bit bitwise OR
+**************************************************************************/
+ficl2Unsigned ficl2UnsignedOr( ficl2Unsigned x, ficl2Unsigned y )
+{
+ ficl2Unsigned result;
+
+ result.high = x.high | y.high;
+ result.low = x.low | y.low;
+
+ return result;
+}
+
+
+/**************************************************************************
+ ficl2UnsignedCompare
+** Return -1 if x < y; 0 if x==y, and 1 if x > y.
+**************************************************************************/
+int ficl2UnsignedCompare(ficl2Unsigned x, ficl2Unsigned y)
+{
+ if (x.high > y.high)
+ return 1;
+ if (x.high < y.high)
+ return -1;
+
+ /* High parts are equal */
+
+ if (x.low > y.low)
+ return 1;
+ else if (x.low < y.low)
+ return -1;
+
+ return 0;
+}
+
+
+
+/**************************************************************************
+ ficl2UnsignedDivide
+** Portable versions of ficl2Multiply and ficl2Divide in C
+** Contributed by:
+** Michael A. Gauland gaulandm@mdhost.cse.tek.com
+**************************************************************************/
+ficl2UnsignedQR ficl2UnsignedDivide(ficl2Unsigned q, ficlUnsigned y)
+{
+ ficl2UnsignedQR result;
+ ficl2Unsigned quotient;
+ ficl2Unsigned subtrahend;
+ ficl2Unsigned mask;
+
+ quotient.low = 0;
+ quotient.high = 0;
+
+ subtrahend.low = y;
+ subtrahend.high = 0;
+
+ mask.low = 1;
+ mask.high = 0;
+
+ while ((ficl2UnsignedCompare(subtrahend, q) < 0) &&
+ (subtrahend.high & FICL_CELL_HIGH_BIT) == 0)
+ {
+ mask = ficl2UnsignedArithmeticShiftLeft(mask);
+ subtrahend = ficl2UnsignedArithmeticShiftLeft(subtrahend);
+ }
+
+ while (mask.low != 0 || mask.high != 0)
+ {
+ if (ficl2UnsignedCompare(subtrahend, q) <= 0)
+ {
+ q = ficl2UnsignedSubtract( q, subtrahend);
+ quotient = ficl2UnsignedOr(quotient, mask);
+ }
+ mask = ficl2UnsignedArithmeticShiftRight(mask);
+ subtrahend = ficl2UnsignedArithmeticShiftRight(subtrahend);
+ }
+
+ result.quotient = quotient;
+ result.remainder = q.low;
+ return result;
+}
+
+#endif /* !FICL_PLATFORM_HAS_2INTEGER */
+
+
+
+/**************************************************************************
+ ficl2IntegerAbsoluteValue
+** Returns the absolute value of an ficl2Unsigned
+**************************************************************************/
+ficl2Integer ficl2IntegerAbsoluteValue(ficl2Integer x)
+{
+ if (ficl2IntegerIsNegative(x))
+ return ficl2IntegerNegate(x);
+ return x;
+}
+
+
+/**************************************************************************
+ ficl2IntegerDivideFloored
+**
+** FROM THE FORTH ANS...
+** Floored division is integer division in which the remainder carries
+** the sign of the divisor or is zero, and the quotient is rounded to
+** its arithmetic floor. Symmetric division is integer division in which
+** the remainder carries the sign of the dividend or is zero and the
+** quotient is the mathematical quotient rounded towards zero or
+** truncated. Examples of each are shown in tables 3.3 and 3.4.
+**
+** Table 3.3 - Floored Division Example
+** Dividend Divisor Remainder Quotient
+** -------- ------- --------- --------
+** 10 7 3 1
+** -10 7 4 -2
+** 10 -7 -4 -2
+** -10 -7 -3 1
+**
+**
+** Table 3.4 - Symmetric Division Example
+** Dividend Divisor Remainder Quotient
+** -------- ------- --------- --------
+** 10 7 3 1
+** -10 7 -3 -1
+** 10 -7 3 -1
+** -10 -7 -3 1
+**************************************************************************/
+ficl2IntegerQR ficl2IntegerDivideFloored(ficl2Integer num, ficlInteger den)
+{
+ ficl2IntegerQR qr;
+ ficl2UnsignedQR uqr;
+ int signRem = 1;
+ int signQuot = 1;
+
+ if (ficl2IntegerIsNegative(num))
+ {
+ num = ficl2IntegerNegate(num);
+ signQuot = -signQuot;
+ }
+
+ if (den < 0)
+ {
+ den = -den;
+ signRem = -signRem;
+ signQuot = -signQuot;
+ }
+
+ uqr = ficl2UnsignedDivide(FICL_2INTEGER_TO_2UNSIGNED(num), (ficlUnsigned)den);
+ qr = FICL_2UNSIGNEDQR_TO_2INTEGERQR(uqr);
+ if (signQuot < 0)
+ {
+ qr.quotient = ficl2IntegerNegate(qr.quotient);
+ if (qr.remainder != 0)
+ {
+ qr.quotient = ficl2IntegerDecrement(qr.quotient);
+ qr.remainder = den - qr.remainder;
+ }
+ }
+
+ if (signRem < 0)
+ qr.remainder = -qr.remainder;
+
+ return qr;
+}
+
+
+
+/**************************************************************************
+ ficl2IntegerDivideSymmetric
+** Divide an ficl2Unsigned by a ficlInteger and return a ficlInteger quotient and a
+** ficlInteger remainder. The absolute values of quotient and remainder are not
+** affected by the signs of the numerator and denominator (the operation
+** is symmetric on the number line)
+**************************************************************************/
+ficl2IntegerQR ficl2IntegerDivideSymmetric(ficl2Integer num, ficlInteger den)
+{
+ ficl2IntegerQR qr;
+ ficl2UnsignedQR uqr;
+ int signRem = 1;
+ int signQuot = 1;
+
+ if (ficl2IntegerIsNegative(num))
+ {
+ num = ficl2IntegerNegate(num);
+ signRem = -signRem;
+ signQuot = -signQuot;
+ }
+
+ if (den < 0)
+ {
+ den = -den;
+ signQuot = -signQuot;
+ }
+
+ uqr = ficl2UnsignedDivide(FICL_2INTEGER_TO_2UNSIGNED(num), (ficlUnsigned)den);
+ qr = FICL_2UNSIGNEDQR_TO_2INTEGERQR(uqr);
+ if (signRem < 0)
+ qr.remainder = -qr.remainder;
+
+ if (signQuot < 0)
+ qr.quotient = ficl2IntegerNegate(qr.quotient);
+
+ return qr;
+}
+
+
diff --git a/extras.c b/extras.c
new file mode 100644
index 000000000000..69ac8fd31bcc
--- /dev/null
+++ b/extras.c
@@ -0,0 +1,267 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <unistd.h>
+
+#include "ficl.h"
+
+
+#ifndef FICL_ANSI
+
+/*
+** Ficl interface to _getcwd (Win32)
+** Prints the current working directory using the VM's
+** textOut method...
+*/
+static void ficlPrimitiveGetCwd(ficlVm *vm)
+{
+ char *directory;
+
+ directory = getcwd(NULL, 80);
+ ficlVmTextOut(vm, directory);
+ ficlVmTextOut(vm, "\n");
+ free(directory);
+ return;
+}
+
+
+
+/*
+** Ficl interface to _chdir (Win32)
+** Gets a newline (or NULL) delimited string from the input
+** and feeds it to the Win32 chdir function...
+** Example:
+** cd c:\tmp
+*/
+static void ficlPrimitiveChDir(ficlVm *vm)
+{
+ ficlCountedString *counted = (ficlCountedString *)vm->pad;
+ ficlVmGetString(vm, counted, '\n');
+ if (counted->length > 0)
+ {
+ int err = chdir(counted->text);
+ if (err)
+ {
+ ficlVmTextOut(vm, "Error: path not found\n");
+ ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
+ }
+ }
+ else
+ {
+ ficlVmTextOut(vm, "Warning (chdir): nothing happened\n");
+ }
+ return;
+}
+
+
+
+static void ficlPrimitiveClock(ficlVm *vm)
+{
+ clock_t now = clock();
+ ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)now);
+ return;
+}
+
+#endif /* FICL_ANSI */
+
+
+/*
+** Ficl interface to system (ANSI)
+** Gets a newline (or NULL) delimited string from the input
+** and feeds it to the ANSI system function...
+** Example:
+** system del *.*
+** \ ouch!
+*/
+static void ficlPrimitiveSystem(ficlVm *vm)
+{
+ ficlCountedString *counted = (ficlCountedString *)vm->pad;
+
+ ficlVmGetString(vm, counted, '\n');
+ if (FICL_COUNTED_STRING_GET_LENGTH(*counted) > 0)
+ {
+ int returnValue = system(FICL_COUNTED_STRING_GET_POINTER(*counted));
+ if (returnValue)
+ {
+ sprintf(vm->pad, "System call returned %d\n", returnValue);
+ ficlVmTextOut(vm, vm->pad);
+ ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
+ }
+ }
+ else
+ {
+ ficlVmTextOut(vm, "Warning (system): nothing happened\n");
+ }
+ return;
+}
+
+
+
+/*
+** Ficl add-in to load a text file and execute it...
+** Cheesy, but illustrative.
+** Line oriented... filename is newline (or NULL) delimited.
+** Example:
+** load test.f
+*/
+#define BUFFER_SIZE 256
+static void ficlPrimitiveLoad(ficlVm *vm)
+{
+ char buffer[BUFFER_SIZE];
+ char filename[BUFFER_SIZE];
+ ficlCountedString *counted = (ficlCountedString *)filename;
+ int line = 0;
+ FILE *f;
+ int result = 0;
+ ficlCell oldSourceId;
+ ficlString s;
+
+ ficlVmGetString(vm, counted, '\n');
+
+ if (FICL_COUNTED_STRING_GET_LENGTH(*counted) <= 0)
+ {
+ ficlVmTextOut(vm, "Warning (load): nothing happened\n");
+ return;
+ }
+
+ /*
+ ** get the file's size and make sure it exists
+ */
+
+ f = fopen(FICL_COUNTED_STRING_GET_POINTER(*counted), "r");
+ if (!f)
+ {
+ ficlVmTextOut(vm, "Unable to open file ");
+ ficlVmTextOut(vm, FICL_COUNTED_STRING_GET_POINTER(*counted));
+ ficlVmTextOut(vm, "\n");
+ ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
+ }
+
+ oldSourceId = vm->sourceId;
+ vm->sourceId.p = (void *)f;
+
+ /* feed each line to ficlExec */
+ while (fgets(buffer, BUFFER_SIZE, f))
+ {
+ int length = strlen(buffer) - 1;
+
+ line++;
+ if (length <= 0)
+ continue;
+
+ if (buffer[length] == '\n')
+ buffer[length--] = '\0';
+
+ FICL_STRING_SET_POINTER(s, buffer);
+ FICL_STRING_SET_LENGTH(s, length + 1);
+ result = ficlVmExecuteString(vm, s);
+ /* handle "bye" in loaded files. --lch */
+ switch (result)
+ {
+ case FICL_VM_STATUS_OUT_OF_TEXT:
+ case FICL_VM_STATUS_USER_EXIT:
+ break;
+
+ default:
+ vm->sourceId = oldSourceId;
+ fclose(f);
+ ficlVmThrowError(vm, "Error loading file <%s> line %d", FICL_COUNTED_STRING_GET_POINTER(*counted), line);
+ break;
+ }
+ }
+ /*
+ ** Pass an empty line with SOURCE-ID == -1 to flush
+ ** any pending REFILLs (as required by FILE wordset)
+ */
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_FROM_CSTRING(s, "");
+ ficlVmExecuteString(vm, s);
+
+ vm->sourceId = oldSourceId;
+ fclose(f);
+
+ /* handle "bye" in loaded files. --lch */
+ if (result == FICL_VM_STATUS_USER_EXIT)
+ ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
+ return;
+}
+
+
+
+/*
+** Dump a tab delimited file that summarizes the contents of the
+** dictionary hash table by hashcode...
+*/
+static void ficlPrimitiveSpewHash(ficlVm *vm)
+{
+ ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
+ ficlWord *word;
+ FILE *f;
+ unsigned i;
+ unsigned hashSize = hash->size;
+
+ if (!ficlVmGetWordToPad(vm))
+ ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT);
+
+ f = fopen(vm->pad, "w");
+ if (!f)
+ {
+ ficlVmTextOut(vm, "unable to open file\n");
+ return;
+ }
+
+ for (i = 0; i < hashSize; i++)
+ {
+ int n = 0;
+
+ word = hash->table[i];
+ while (word)
+ {
+ n++;
+ word = word->link;
+ }
+
+ fprintf(f, "%d\t%d", i, n);
+
+ word = hash->table[i];
+ while (word)
+ {
+ fprintf(f, "\t%s", word->name);
+ word = word->link;
+ }
+
+ fprintf(f, "\n");
+ }
+
+ fclose(f);
+ return;
+}
+
+static void ficlPrimitiveBreak(ficlVm *vm)
+{
+ vm->state = vm->state;
+ return;
+}
+
+
+
+void ficlSystemCompileExtras(ficlSystem *system)
+{
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+
+ ficlDictionarySetPrimitive(dictionary, "break", ficlPrimitiveBreak, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "load", ficlPrimitiveLoad, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "spewhash", ficlPrimitiveSpewHash, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "system", ficlPrimitiveSystem, FICL_WORD_DEFAULT);
+
+#ifndef FICL_ANSI
+ ficlDictionarySetPrimitive(dictionary, "clock", ficlPrimitiveClock, FICL_WORD_DEFAULT);
+ ficlDictionarySetConstant(dictionary, "clocks/sec", CLOCKS_PER_SEC);
+ ficlDictionarySetPrimitive(dictionary, "pwd", ficlPrimitiveGetCwd, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "cd", ficlPrimitiveChDir, FICL_WORD_DEFAULT);
+#endif /* FICL_ANSI */
+
+ return;
+}
+
diff --git a/ficl.c b/ficl.c
deleted file mode 100644
index a9b4029f6438..000000000000
--- a/ficl.c
+++ /dev/null
@@ -1,691 +0,0 @@
-/*******************************************************************
-** f i c l . c
-** Forth Inspired Command Language - external interface
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 19 July 1997
-** $Id: ficl.c,v 1.17 2001-12-04 17:58:11-08 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** This is an ANS Forth interpreter written in C.
-** Ficl uses Forth syntax for its commands, but turns the Forth
-** model on its head in other respects.
-** Ficl provides facilities for interoperating
-** with programs written in C: C functions can be exported to Ficl,
-** and Ficl commands can be executed via a C calling interface. The
-** interpreter is re-entrant, so it can be used in multiple instances
-** in a multitasking system. Unlike Forth, Ficl's outer interpreter
-** expects a text block as input, and returns to the caller after each
-** text block, so the data pump is somewhere in external code in the
-** style of TCL.
-**
-** Code is written in ANSI C for portability.
-*/
-/*
-** 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
-** 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 <stdlib.h>
-#include <string.h>
-#include "ficl.h"
-
-
-/*
-** System statics
-** Each FICL_SYSTEM builds a global dictionary during its start
-** sequence. This is shared by all virtual machines of that system.
-** Therefore only one VM can update the dictionary
-** at a time. The system imports a locking function that
-** you can override in order to control update access to
-** the dictionary. The function is stubbed out by default,
-** but you can insert one: #define FICL_MULTITHREAD 1
-** and supply your own version of ficlLockDictionary.
-*/
-static int defaultStack = FICL_DEFAULT_STACK;
-
-
-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.
-** You specify the address and size of the allocated area.
-** 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.
-** The dictionary needs to be at least large enough to hold the
-** 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)
-{
- int nDictCells;
- int nEnvCells;
- FICL_SYSTEM *pSys = ficlMalloc(sizeof (FICL_SYSTEM));
-
- assert(pSys);
- assert(fsi->size == sizeof (FICL_SYSTEM_INFO));
-
- memset(pSys, 0, sizeof (FICL_SYSTEM));
-
- nDictCells = fsi->nDictCells;
- if (nDictCells <= 0)
- nDictCells = FICL_DEFAULT_DICT;
-
- nEnvCells = fsi->nEnvCells;
- if (nEnvCells <= 0)
- nEnvCells = FICL_DEFAULT_DICT;
-
- pSys->dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
- pSys->dp->pForthWords->name = "forth-wordlist";
-
- pSys->envp = dictCreate((unsigned)nEnvCells);
- pSys->envp->pForthWords->name = "environment";
-
- pSys->textOut = fsi->textOut;
- pSys->pExtend = fsi->pExtend;
-
-#if FICL_WANT_LOCALS
- /*
- ** The locals dictionary is only searched while compiling,
- ** but this is where speed is most important. On the other
- ** hand, the dictionary gets emptied after each use of locals
- ** The need to balance search speed with the cost of the 'empty'
- ** operation led me to select a single-threaded list...
- */
- pSys->localp = dictCreate((unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
-#endif
-
- /*
- ** 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.
- ** ficl 2.05: vmCreate no longer depends on the presence of INTERPRET in the
- ** dictionary, so a VM can be created before the dictionary is built. It just
- ** can't do much...
- */
- ficlNewVM(pSys);
- ficlCompileSoftCore(pSys);
- ficlFreeVM(pSys->vmList);
-
-
- return pSys;
-}
-
-
-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
-** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
-** nonzero if there's no more room in the list.
-**************************************************************************/
-int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW)
-{
- int i;
- for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
- {
- if (pSys->parseList[i] == NULL)
- {
- pSys->parseList[i] = pFW;
- return 0;
- }
- }
-
- return 1;
-}
-
-
-/*
-** Compile a word into the dictionary that invokes the specified FICL_PARSE_STEP
-** function. It is up to the user (as usual in Forth) to make sure the stack
-** preconditions are valid (there needs to be a counted string on top of the stack)
-** before using the resulting word.
-*/
-void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep)
-{
- FICL_DICT *dp = pSys->dp;
- FICL_WORD *pFW = dictAppendWord(dp, name, parseStepParen, FW_DEFAULT);
- dictAppendCell(dp, LVALUEtoCELL(pStep));
- ficlAddParseStep(pSys, pFW);
-}
-
-
-/*
-** This word lists the parse steps in order
-*/
-void ficlListParseSteps(FICL_VM *pVM)
-{
- int i;
- FICL_SYSTEM *pSys = pVM->pSys;
- assert(pSys);
-
- vmTextOut(pVM, "Parse steps:", 1);
- vmTextOut(pVM, "lookup", 1);
-
- for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
- {
- if (pSys->parseList[i] != NULL)
- {
- vmTextOut(pVM, pSys->parseList[i]->name, 1);
- }
- else break;
- }
- return;
-}
-
-
-/**************************************************************************
- f i c l N e w V M
-** Create a new virtual machine and link it into the system list
-** of VMs for later cleanup by ficlTermSystem.
-**************************************************************************/
-FICL_VM *ficlNewVM(FICL_SYSTEM *pSys)
-{
- FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
- pVM->link = pSys->vmList;
- pVM->pSys = pSys;
- pVM->pExtend = pSys->pExtend;
- vmSetTextOut(pVM, pSys->textOut);
-
- pSys->vmList = pVM;
- return pVM;
-}
-
-
-/**************************************************************************
- f i c l F r e e V M
-** Removes the VM in question from the system VM list and deletes the
-** memory allocated to it. This is an optional call, since ficlTermSystem
-** will do this cleanup for you. This function is handy if you're going to
-** do a lot of dynamic creation of VMs.
-**************************************************************************/
-void ficlFreeVM(FICL_VM *pVM)
-{
- FICL_SYSTEM *pSys = pVM->pSys;
- FICL_VM *pList = pSys->vmList;
-
- assert(pVM != 0);
-
- if (pSys->vmList == pVM)
- {
- pSys->vmList = pSys->vmList->link;
- }
- else for (; pList != NULL; pList = pList->link)
- {
- if (pList->link == pVM)
- {
- pList->link = pVM->link;
- break;
- }
- }
-
- if (pList)
- vmDelete(pVM);
- return;
-}
-
-
-/**************************************************************************
- f i c l B u i l d
-** Builds a word into the dictionary.
-** Preconditions: system must be initialized, and there must
-** be enough space for the new word's header! Operation is
-** controlled by ficlLockDictionary, so any initialization
-** required by your version of the function (if you overrode
-** it) must be complete at this point.
-** Parameters:
-** name -- duh, the name of the word
-** code -- code to execute when the word is invoked - must take a single param
-** pointer to a FICL_VM
-** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR!
-**
-**************************************************************************/
-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);
-
- ficlLockDictionary(FALSE);
- return 0;
-}
-
-
-/**************************************************************************
- 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
-** interpreter's output function.
-**
-** Contains the "inner interpreter" code in a tight loop
-**
-** Returns one of the VM_XXXX codes defined in ficl.h:
-** VM_OUTOFTEXT is the normal exit condition
-** VM_ERREXIT means that the interp encountered a syntax error
-** and the vm has been reset to recover (some or all
-** of the text block got ignored
-** VM_USEREXIT means that the user executed the "bye" command
-** to shut down the interpreter. This would be a good
-** time to delete the vm, etc -- or you can ignore this
-** signal.
-**************************************************************************/
-int ficlExec(FICL_VM *pVM, char *pText)
-{
- return ficlExecC(pVM, pText, -1);
-}
-
-int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
-{
- FICL_SYSTEM *pSys = pVM->pSys;
- FICL_DICT *dp = pSys->dp;
-
- int except;
- jmp_buf vmState;
- jmp_buf *oldState;
- TIB saveTib;
-
- assert(pVM);
- assert(pSys->pInterp[0]);
-
- if (size < 0)
- size = strlen(pText);
-
- vmPushTib(pVM, pText, size, &saveTib);
-
- /*
- ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
- */
- oldState = pVM->pState;
- pVM->pState = &vmState; /* This has to come before the setjmp! */
- except = setjmp(vmState);
-
- switch (except)
- {
- case 0:
- if (pVM->fRestart)
- {
- pVM->runningWord->code(pVM);
- pVM->fRestart = 0;
- }
- else
- { /* set VM up to interpret text */
- vmPushIP(pVM, &(pSys->pInterp[0]));
- }
-
- vmInnerLoop(pVM);
- break;
-
- case VM_RESTART:
- pVM->fRestart = 1;
- except = VM_OUTOFTEXT;
- break;
-
- case VM_OUTOFTEXT:
- vmPopIP(pVM);
- if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
- ficlTextOut(pVM, FICL_PROMPT, 0);
- break;
-
- case VM_USEREXIT:
- case VM_INNEREXIT:
- case VM_BREAK:
- break;
-
- case VM_QUIT:
- if (pVM->state == COMPILE)
- {
- dictAbortDefinition(dp);
-#if FICL_WANT_LOCALS
- dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
-#endif
- }
- vmQuit(pVM);
- break;
-
- case VM_ERREXIT:
- case VM_ABORT:
- case VM_ABORTQ:
- default: /* user defined exit code?? */
- if (pVM->state == COMPILE)
- {
- dictAbortDefinition(dp);
-#if FICL_WANT_LOCALS
- dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
-#endif
- }
- dictResetSearchOrder(dp);
- vmReset(pVM);
- break;
- }
-
- pVM->pState = oldState;
- vmPopTib(pVM, &saveTib);
- return (except);
-}
-
-
-/**************************************************************************
- f i c l E x e c X T
-** Given a pointer to a FICL_WORD, push an inner interpreter and
-** execute the word to completion. This is in contrast with vmExecute,
-** which does not guarantee that the word will have completed when
-** the function returns (ie in the case of colon definitions, which
-** need an inner interpreter to finish)
-**
-** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
-** exit condition is VM_INNEREXIT, ficl's private signal to exit the
-** inner loop under normal circumstances. If another code is thrown to
-** exit the loop, this function will re-throw it if it's nested under
-** itself or ficlExec.
-**
-** NOTE: this function is intended so that C code can execute ficlWords
-** given their address in the dictionary (xt).
-**************************************************************************/
-int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
-{
- int except;
- jmp_buf vmState;
- jmp_buf *oldState;
- FICL_WORD *oldRunningWord;
-
- assert(pVM);
- assert(pVM->pSys->pExitInner);
-
- /*
- ** Save the runningword so that RESTART behaves correctly
- ** over nested calls.
- */
- oldRunningWord = pVM->runningWord;
- /*
- ** Save and restore VM's jmp_buf to enable nested calls
- */
- oldState = pVM->pState;
- pVM->pState = &vmState; /* This has to come before the setjmp! */
- except = setjmp(vmState);
-
- if (except)
- vmPopIP(pVM);
- else
- vmPushIP(pVM, &(pVM->pSys->pExitInner));
-
- switch (except)
- {
- case 0:
- vmExecute(pVM, pWord);
- vmInnerLoop(pVM);
- break;
-
- case VM_INNEREXIT:
- case VM_BREAK:
- break;
-
- case VM_RESTART:
- case VM_OUTOFTEXT:
- case VM_USEREXIT:
- case VM_QUIT:
- case VM_ERREXIT:
- case VM_ABORT:
- case VM_ABORTQ:
- default: /* user defined exit code?? */
- if (oldState)
- {
- pVM->pState = oldState;
- vmThrow(pVM, except);
- }
- break;
- }
-
- pVM->pState = oldState;
- pVM->runningWord = oldRunningWord;
- return (except);
-}
-
-
-/**************************************************************************
- f i c l L o o k u p
-** Look in the system dictionary for a match to the given name. If
-** found, return the address of the corresponding FICL_WORD. Otherwise
-** return NULL.
-**************************************************************************/
-FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name)
-{
- STRINGINFO si;
- SI_PSZ(si, name);
- return dictLookup(pSys->dp, si);
-}
-
-
-/**************************************************************************
- f i c l G e t D i c t
-** Returns the address of the system dictionary
-**************************************************************************/
-FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys)
-{
- return pSys->dp;
-}
-
-
-/**************************************************************************
- f i c l G e t E n v
-** Returns the address of the system environment space
-**************************************************************************/
-FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys)
-{
- return pSys->envp;
-}
-
-
-/**************************************************************************
- f i c l S e t E n v
-** Create an environment variable with a one-CELL payload. ficlSetEnvD
-** makes one with a two-CELL payload.
-**************************************************************************/
-void ficlSetEnv(FICL_SYSTEM *pSys, char *name, FICL_UNS value)
-{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_DICT *envp = pSys->envp;
-
- SI_PSZ(si, name);
- pFW = dictLookup(envp, si);
-
- if (pFW == NULL)
- {
- dictAppendWord(envp, name, constantParen, FW_DEFAULT);
- dictAppendCell(envp, LVALUEtoCELL(value));
- }
- else
- {
- pFW->param[0] = LVALUEtoCELL(value);
- }
-
- return;
-}
-
-void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo)
-{
- FICL_WORD *pFW;
- STRINGINFO si;
- FICL_DICT *envp = pSys->envp;
- SI_PSZ(si, name);
- pFW = dictLookup(envp, si);
-
- if (pFW == NULL)
- {
- dictAppendWord(envp, name, twoConstParen, FW_DEFAULT);
- dictAppendCell(envp, LVALUEtoCELL(lo));
- dictAppendCell(envp, LVALUEtoCELL(hi));
- }
- else
- {
- pFW->param[0] = LVALUEtoCELL(lo);
- pFW->param[1] = LVALUEtoCELL(hi);
- }
-
- return;
-}
-
-
-/**************************************************************************
- f i c l G e t L o c
-** Returns the address of the system locals dictionary. This dict is
-** only used during compilation, and is shared by all VMs.
-**************************************************************************/
-#if FICL_WANT_LOCALS
-FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys)
-{
- return pSys->localp;
-}
-#endif
-
-
-
-/**************************************************************************
- f i c l S e t S t a c k S i z e
-** Set the stack sizes (return and parameter) to be used for all
-** subsequently created VMs. Returns actual stack size to be used.
-**************************************************************************/
-int ficlSetStackSize(int nStackCells)
-{
- if (nStackCells >= FICL_DEFAULT_STACK)
- defaultStack = nStackCells;
- else
- defaultStack = FICL_DEFAULT_STACK;
-
- return defaultStack;
-}
-
-
-/**************************************************************************
- f i c l T e r m S y s t e m
-** Tear the system down by deleting the dictionaries and all VMs.
-** This saves you from having to keep track of all that stuff.
-**************************************************************************/
-void ficlTermSystem(FICL_SYSTEM *pSys)
-{
- if (pSys->dp)
- dictDelete(pSys->dp);
- pSys->dp = NULL;
-
- if (pSys->envp)
- dictDelete(pSys->envp);
- pSys->envp = NULL;
-
-#if FICL_WANT_LOCALS
- if (pSys->localp)
- dictDelete(pSys->localp);
- pSys->localp = NULL;
-#endif
-
- while (pSys->vmList != NULL)
- {
- FICL_VM *pVM = pSys->vmList;
- pSys->vmList = pSys->vmList->link;
- vmDelete(pVM);
- }
-
- ficlFree(pSys);
- pSys = NULL;
- 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);
- ficlSetEnv (pSys, "ficl-robust", FICL_ROBUST);
- return;
-}
-
diff --git a/ficl.dsp b/ficl.dsp
deleted file mode 100644
index ec661b830928..000000000000
--- a/ficl.dsp
+++ /dev/null
@@ -1,301 +0,0 @@
-# Microsoft Developer Studio Project File - Name="ficl" - Package Owner=<4>
-# Microsoft Developer Studio Generated Build File, Format Version 6.00
-# ** DO NOT EDIT **
-
-# TARGTYPE "Win32 (x86) Console Application" 0x0103
-
-CFG=ficl - Win32 Debug
-!MESSAGE This is not a valid makefile. To build this project using NMAKE,
-!MESSAGE use the Export Makefile command and run
-!MESSAGE
-!MESSAGE NMAKE /f "ficl.mak".
-!MESSAGE
-!MESSAGE You can specify a configuration when running NMAKE
-!MESSAGE by defining the macro CFG on the command line. For example:
-!MESSAGE
-!MESSAGE NMAKE /f "ficl.mak" CFG="ficl - Win32 Debug"
-!MESSAGE
-!MESSAGE Possible choices for configuration are:
-!MESSAGE
-!MESSAGE "ficl - Win32 Release" (based on "Win32 (x86) Console Application")
-!MESSAGE "ficl - Win32 Debug" (based on "Win32 (x86) Console Application")
-!MESSAGE
-
-# Begin Project
-# PROP AllowPerConfigDependencies 0
-# PROP Scc_ProjName ""
-# PROP Scc_LocalPath ""
-CPP=cl.exe
-RSC=rc.exe
-
-!IF "$(CFG)" == "ficl - Win32 Release"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 0
-# PROP BASE Output_Dir "Release"
-# PROP BASE Intermediate_Dir "Release"
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 0
-# PROP Output_Dir "release"
-# PROP Intermediate_Dir "release"
-# PROP Target_Dir ""
-# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
-# ADD CPP /nologo /W4 /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /FD /c
-# SUBTRACT CPP /Fr /YX
-# ADD BASE RSC /l 0x409 /d "NDEBUG"
-# ADD RSC /l 0x409 /d "NDEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386
-# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386
-
-!ELSEIF "$(CFG)" == "ficl - Win32 Debug"
-
-# PROP BASE Use_MFC 0
-# PROP BASE Use_Debug_Libraries 1
-# PROP BASE Output_Dir "Debug"
-# PROP BASE Intermediate_Dir "Debug"
-# PROP BASE Target_Dir ""
-# PROP Use_MFC 0
-# PROP Use_Debug_Libraries 1
-# PROP Output_Dir "debug"
-# PROP Intermediate_Dir "debug"
-# PROP Ignore_Export_Lib 0
-# PROP Target_Dir ""
-# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
-# ADD CPP /nologo /Za /W4 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /FR /FD /c
-# SUBTRACT CPP /YX
-# ADD BASE RSC /l 0x409 /d "_DEBUG"
-# ADD RSC /l 0x409 /d "_DEBUG"
-BSC32=bscmake.exe
-# ADD BASE BSC32 /nologo
-# ADD BSC32 /nologo
-LINK32=link.exe
-# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
-# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
-
-!ENDIF
-
-# Begin Target
-
-# Name "ficl - Win32 Release"
-# Name "ficl - Win32 Debug"
-# Begin Group "Sources"
-
-# PROP Default_Filter "*.c"
-# Begin Source File
-
-SOURCE=.\dict.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\ficl.c
-
-!IF "$(CFG)" == "ficl - Win32 Release"
-
-# ADD CPP /FAcs
-
-!ELSEIF "$(CFG)" == "ficl - Win32 Debug"
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\fileaccess.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\float.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\math64.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\prefix.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\search.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\softcore.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\stack.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\sysdep.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\testmain.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\tools.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\vm.c
-# End Source File
-# Begin Source File
-
-SOURCE=.\win32.c
-
-!IF "$(CFG)" == "ficl - Win32 Release"
-
-!ELSEIF "$(CFG)" == "ficl - Win32 Debug"
-
-# ADD CPP /Ze
-
-!ENDIF
-
-# End Source File
-# Begin Source File
-
-SOURCE=.\words.c
-# End Source File
-# End Group
-# Begin Group "Headers"
-
-# PROP Default_Filter "*.h"
-# Begin Source File
-
-SOURCE=.\ficl.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\math64.h
-# End Source File
-# Begin Source File
-
-SOURCE=.\sysdep.h
-# End Source File
-# End Group
-# Begin Group "softcore"
-
-# PROP Default_Filter ".fr"
-# Begin Source File
-
-SOURCE=.\softwords\classes.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\ficlclass.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\ficllocal.fr
-# 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
-
-SOURCE=.\softwords\ifbrack.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\jhlocal.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\marker.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\oo.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\prefix.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\softcore.bat
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\softcore.fr
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\softcore.pl
-# End Source File
-# Begin Source File
-
-SOURCE=.\softwords\string.fr
-# End Source File
-# End Group
-# Begin Group "doc"
-
-# PROP Default_Filter "*.html. *.txt"
-# Begin Source File
-
-SOURCE=.\doc\ficl.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_ans.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_debug.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\ficl_guts.htm
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_loc.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_oop.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_parse.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficl_rel.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\ficlheader.js
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\index.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\oo_in_c.html
-# End Source File
-# Begin Source File
-
-SOURCE=.\doc\primer.txt
-# End Source File
-# End Group
-# Begin Source File
-
-SOURCE=.\ReadMe.txt
-# End Source File
-# End Target
-# End Project
diff --git a/ficl.dsw b/ficl.dsw
index dfa2a266742e..af8c3448ed81 100644
--- a/ficl.dsw
+++ b/ficl.dsw
@@ -1,29 +1,59 @@
-Microsoft Developer Studio Workspace File, Format Version 6.00
-# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
-
-###############################################################################
-
-Project: "ficl"=.\ficl.dsp - Package Owner=<4>
-
-Package=<5>
-{{{
-}}}
-
-Package=<4>
-{{{
-}}}
-
-###############################################################################
-
-Global:
-
-Package=<5>
-{{{
-}}}
-
-Package=<3>
-{{{
-}}}
-
-###############################################################################
-
+Microsoft Developer Studio Workspace File, Format Version 6.00
+# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
+
+###############################################################################
+
+Project: "ficldll"=.\ficldll.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+ Begin Project Dependency
+ Project_Dep_Name ficllib
+ End Project Dependency
+}}}
+
+###############################################################################
+
+Project: "ficlexe"=.\ficlexe.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+ Begin Project Dependency
+ Project_Dep_Name ficllib
+ End Project Dependency
+}}}
+
+###############################################################################
+
+Project: "ficllib"=.\ficllib.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+}}}
+
+###############################################################################
+
+Global:
+
+Package=<5>
+{{{
+}}}
+
+Package=<3>
+{{{
+}}}
+
+###############################################################################
+
diff --git a/ficl.h b/ficl.h
index 387259d0a287..3a32b548e782 100644
--- a/ficl.h
+++ b/ficl.h
@@ -4,17 +4,17 @@
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** Dedicated to RHS, in loving memory
-** $Id: ficl.h,v 1.19 2001-12-04 17:58:07-08 jsadler Exp jsadler $
-*******************************************************************/
-/*
+** $Id: ficl.h,v 1.25 2010/10/03 09:52:12 asau Exp $
+********************************************************************
+**
** 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
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -66,7 +66,7 @@
** in a multitasking system. Unlike Forth, Ficl's outer interpreter
** expects a text block as input, and returns to the caller after each
** text block, so the "data pump" is somewhere in external code. This
-** is more like TCL than Forth, which usually expcets to be at the center
+** is more like TCL than Forth, which usually expects to be at the center
** of the system, requesting input at its convenience. Each Ficl virtual
** machine can be bound to a different I/O channel, and is independent
** of all others in in the same address space except that all virtual
@@ -114,10 +114,10 @@
** system. For example, INT16 is a short on some compilers and an
** int on others. Check the default CELL alignment controlled by
** FICL_ALIGN. If necessary, add new definitions of ficlMalloc, ficlFree,
-** ficlLockDictionary, and ficlTextOut to work with your operating system.
-** Finally, use testmain.c as a guide to installing the Ficl system and
-** one or more virtual machines into your code. You do not need to include
-** testmain.c in your build.
+** ficlLockDictionary, and ficlCallbackDefaultTextOut to work with your
+** operating system. Finally, use testmain.c as a guide to installing the
+** Ficl system and one or more virtual machines into your code. You do not
+** need to include testmain.c in your build.
**
** T o D o L i s t
**
@@ -128,117 +128,514 @@
**
** F o r M o r e I n f o r m a t i o n
**
-** Web home of ficl
+** Web home of Ficl
** http://ficl.sourceforge.net
** Check this website for Forth literature (including the ANSI standard)
** http://www.taygeta.com/forthlit.html
** and here for software and more links
** http://www.taygeta.com/forth.html
+*/
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <limits.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+/*
+** Put all your local defines in ficllocal.h,
+** rather than editing the makefile/project/etc.
+** ficllocal.h will always ship as an inert file.
+*/
+#include "ficllocal.h"
+
+
+
+
+#if defined(FICL_ANSI)
+ #include "ficlplatform/ansi.h"
+#elif defined(_WIN32)
+ #include "ficlplatform/win32.h"
+#elif defined (FREEBSD_ALPHA)
+ #include "ficlplatform/alpha.h"
+#elif defined(unix) || defined(__unix__) || defined(__unix)
+ #include "ficlplatform/unix.h"
+#else /* catch-all */
+ #include "ficlplatform/ansi.h"
+#endif /* platform */
+
+
+
+/*
+**
+** B U I L D C O N T R O L S
**
-** Obvious Performance enhancement opportunities
-** Compile speed
-** - work on interpret speed
-** - turn off locals (FICL_WANT_LOCALS)
-** Interpret speed
-** - Change inner interpreter (and everything else)
-** so that a definition is a list of pointers to functions
-** and inline data rather than pointers to words. This gets
-** rid of vm->runningWord and a level of indirection in the
-** inner loop. I'll look at it for ficl 3.0
-** - Make the main hash table a bigger prime (HASHSIZE)
-** - FORGET about twiddling the hash function - my experience is
-** that that is a waste of time.
-** - Eliminate the need to pass the pVM parameter on the stack
-** by dedicating a register to it. Most words need access to the
-** vm, but the parameter passing overhead can be reduced. One way
-** requires that the host OS have a task switch callout. Create
-** a global variable for the running VM and refer to it in words
-** that need VM access. Alternative: use thread local storage.
-** For single threaded implementations, you can just use a global.
-** The first two solutions create portability problems, so I
-** haven't considered doing them. Another possibility is to
-** declare the pVm parameter to be "register", and hope the compiler
-** pays attention.
+** First, the FICL_WANT_* settings.
+** These are all optional settings that you may or may not
+** want Ficl to use.
**
*/
/*
-** Revision History:
-**
-** 15 Apr 1999 (sadler) Merged FreeBSD changes for exception wordset and
-** counted strings in ficlExec.
-** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an
-** "end" field, and all words respect this. ficlExec is passed a "size"
-** of TIB, as well as vmPushTib. This size is used to calculate the "end"
-** of the string, ie, base+size. If the size is not known, pass -1.
+** FICL_WANT_MINIMAL
+** If set to nonzero, build the smallest possible Ficl interpreter.
+*/
+#if !defined(FICL_WANT_MINIMAL)
+#define FICL_WANT_MINIMAL (0)
+#endif
+
+#if FICL_WANT_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)
+#define FICL_WANT_DEBUGGER (0)
+#define FICL_WANT_OOP (0)
+#define FICL_WANT_PLATFORM (0)
+#define FICL_WANT_MULTITHREADED (0)
+#define FICL_WANT_EXTENDED_PREFIX (0)
+
+#define FICL_ROBUST (0)
+
+#endif /* FICL_WANT_MINIMAL */
+
+
+/*
+** FICL_WANT_PLATFORM
+** Includes words defined in ficlCompilePlatform
+** (see ficlplatform/win32.c and ficlplatform/unix.c for example)
+*/
+#if !defined (FICL_WANT_PLATFORM)
+#define FICL_WANT_PLATFORM (0)
+#endif /* FICL_WANT_PLATFORM */
+
+
+/*
+** FICL_WANT_COMPATIBILITY
+** Changes Ficl 4 at compile-time so it is source-compatible
+** with the Ficl 3 API. If you are a new user to Ficl you
+** don't need to worry about this setting; if you are upgrading
+** from a pre-4.0 version of Ficl, see doc/upgrading.html for
+** more information.
+*/
+#if !defined FICL_WANT_COMPATIBILITY
+#define FICL_WANT_COMPATIBILITY (0)
+#endif /* !defined FICL_WANT_COMPATIBILITY */
+
+
+
+/*
+** FICL_WANT_LZ_SOFTCORE
+** If nonzero, the softcore words are stored compressed
+** with patent-unencumbered Lempel-Ziv '77 compression.
+** This results in a smaller Ficl interpreter, and adds
+** only a *tiny* runtime speed hit.
**
-** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing
-** words has been modified to conform to EXCEPTION EXT word set.
+** As of version 4.0.27, all the runtime code for the decompressor
+** is 688 bytes on a single-threaded release build, but saves 14179
+** bytes of data. That's a net savings of over 13k! Plus, it makes
+** the resulting executable harder to hack :)
**
-** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT,
-** SEARCH / SEARCH EXT, TOOLS / TOOLS EXT.
-** Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD,
-** EMPTY to clear stack.
+** On my 850MHz Duron machine, decompression took 0.00384 seconds
+** if QueryPerformanceCounter() can be believed... it claims that it
+** took 13765 cycles to complete, and that my machine runs 3579545
+** cycles/second.
**
-** 29 jun 1998 (sadler) added variable sized hash table support
-** and ANS Forth optional SEARCH & SEARCH EXT word set.
-** 26 May 1998 (sadler)
-** FICL_PROMPT macro
-** 14 April 1998 (sadler) V1.04
-** Ficlwin: Windows version, Skip Carter's Linux port
-** 5 March 1998 (sadler) V1.03
-** Bug fixes -- passes John Ryan's ANS test suite "core.fr"
+** Contributed by Larry Hastings.
+*/
+#if !defined (FICL_WANT_LZ_SOFTCORE)
+#define FICL_WANT_LZ_SOFTCORE (1)
+#endif /* FICL_WANT_LZ_SOFTCORE */
+
+
+/*
+** 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_FILE */
+
+/*
+** FICL_WANT_FLOAT
+** Includes a floating point stack for the VM, and words to do float operations.
+** Contributed by Guy Carver
+*/
+#if !defined (FICL_WANT_FLOAT)
+#define FICL_WANT_FLOAT (1)
+#endif /* FICL_WANT_FLOAT */
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER (1)
+#endif /* FICL_WANT_DEBUGGER */
+
+/*
+** 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_WANT_EXTENDED_PREFIX
+#define FICL_WANT_EXTENDED_PREFIX (0)
+#endif /* FICL_WANT_EXTENDED_PREFIX */
+
+/*
+** FICL_WANT_USER
+** Enables user variables: per-instance variables bound to the VM.
+** Kind of like thread-local storage. Could be implemented in a
+** VM private dictionary, but I've chosen the lower overhead
+** approach of an array of CELLs instead.
+*/
+#if !defined FICL_WANT_USER
+#define FICL_WANT_USER (1)
+#endif /* FICL_WANT_USER */
+
+/*
+** FICL_WANT_LOCALS
+** Controls the creation of the LOCALS wordset
+** and a private dictionary for local variable compilation.
+*/
+#if !defined FICL_WANT_LOCALS
+#define FICL_WANT_LOCALS (1)
+#endif /* FICL_WANT_LOCALS */
+
+/*
+** FICL_WANT_OOP
+** Inludes object oriented programming support (in softwords)
+** OOP support requires locals and user variables!
+*/
+#if !defined (FICL_WANT_OOP)
+#define FICL_WANT_OOP ((FICL_WANT_LOCALS) && (FICL_WANT_USER))
+#endif /* FICL_WANT_OOP */
+
+/*
+** FICL_WANT_SOFTWORDS
+** Controls inclusion of all softwords in softcore.c.
+*/
+#if !defined (FICL_WANT_SOFTWORDS)
+#define FICL_WANT_SOFTWORDS (1)
+#endif /* FICL_WANT_SOFTWORDS */
+
+/*
+** FICL_WANT_MULTITHREADED
+** Enables dictionary mutual exclusion wia the
+** ficlLockDictionary() system dependent function.
**
-** 24 February 1998 (sadler) V1.02
-** -Fixed bugs in <# # #>
-** -Changed FICL_WORD so that storage for the name characters
-** can be allocated from the dictionary as needed rather than
-** reserving 32 bytes in each word whether needed or not -
-** this saved 50% of the dictionary storage requirement.
-** -Added words in testmain for Win32 functions system,chdir,cwd,
-** also added a word that loads and evaluates a file.
+** Note: this implementation is experimental and poorly
+** tested. Further, it's unnecessary unless you really
+** intend to have multiple SESSIONS (poor choice of name
+** on my part) - that is, threads that modify the dictionary
+** at the same time.
+*/
+#if !defined FICL_WANT_MULTITHREADED
+#define FICL_WANT_MULTITHREADED (0)
+#endif /* FICL_WANT_MULTITHREADED */
+
+
+/*
+** FICL_WANT_OPTIMIZE
+** Do you want to optimize for size, or for speed?
+** Note that this doesn't affect Ficl very much one way
+** or the other at the moment.
+** Contributed by Larry Hastings
+*/
+#define FICL_OPTIMIZE_FOR_SPEED (1)
+#define FICL_OPTIMIZE_FOR_SIZE (2)
+#if !defined (FICL_WANT_OPTIMIZE)
+#define FICL_WANT_OPTIMIZE FICL_OPTIMIZE_FOR_SPEED
+#endif /* FICL_WANT_OPTIMIZE */
+
+
+/*
+** FICL_WANT_VCALL
+** Ficl OO support for calling vtable methods. Win32 only.
+** Contributed by Guy Carver
+*/
+#if !defined (FICL_WANT_VCALL)
+#define FICL_WANT_VCALL (0)
+#endif /* FICL_WANT_VCALL */
+
+
+
+/*
+** P L A T F O R M S E T T I N G S
**
-** December 1997 (sadler)
-** -Added VM_RESTART exception handling in ficlExec -- this lets words
-** that require additional text to succeed (like :, create, variable...)
-** recover gracefully from an empty input buffer rather than emitting
-** an error message. Definitions can span multiple input blocks with
-** no restrictions.
-** -Changed #include order so that <assert.h> is included in sysdep.h,
-** and sysdep is included in all other files. This lets you define
-** NDEBUG in sysdep.h to disable assertions if you want to.
-** -Make PC specific system dependent code conditional on _M_IX86
-** defined so that ports can coexist in sysdep.h/sysdep.c
+** The FICL_PLATFORM_* settings.
+** These indicate attributes about the local platform.
*/
-#ifdef __cplusplus
-extern "C" {
+
+/*
+** FICL_PLATFORM_OS
+** String constant describing the current hardware architecture.
+*/
+#if !defined (FICL_PLATFORM_ARCHITECTURE)
+#define FICL_PLATFORM_ARCHITECTURE "unknown"
#endif
-#include "sysdep.h"
-#include <limits.h> /* UCHAR_MAX */
-#include <stdio.h>
+/*
+** FICL_PLATFORM_OS
+** String constant describing the current operating system.
+*/
+#if !defined (FICL_PLATFORM_OS)
+#define FICL_PLATFORM_OS "unknown"
+#endif
+
+/*
+** FICL_PLATFORM_HAS_2INTEGER
+** Indicates whether or not the current architecture
+** supports a native double-width integer type.
+** If you set this to 1 in your ficlplatform/ *.h file,
+** you *must* create typedefs for the following two types:
+** ficl2Unsigned
+** ficl2Integer
+** If this is set to 0, Ficl will implement double-width
+** integer math in C, which is both bigger *and* slower
+** (the double whammy!). Make sure your compiler really
+** genuinely doesn't support native double-width integers
+** before setting this to 0.
+*/
+#if !defined (FICL_PLATFORM_HAS_2INTEGER)
+#define FICL_PLATFORM_HAS_2INTEGER (0)
+#endif
+
+/*
+** FICL_PLATFORM_HAS_FTRUNCATE
+** Indicates whether or not the current platform provides
+** the ftruncate() function (available on most UNIXes).
+** This function is necessary to provide the complete
+** File-Access wordset.
+**
+** If your platform does not have ftruncate() per se,
+** but does have some method of truncating files, you
+** should be able to implement ftruncate() yourself and
+** set this constant to 1. For an example of this see
+** "ficlplatform/win32.c".
+*/
+#if !defined (FICL_PLATFORM_HAS_FTRUNCATE)
+#define FICL_PLATFORM_HAS_FTRUNCATE (0)
+#endif
+
+
+/*
+** FICL_PLATFORM_INLINE
+** Must be defined, should be a function prototype type-modifying
+** keyword that makes a function "inline". Ficl does not assume
+** that the local platform supports inline functions; it therefore
+** only uses "inline" where "static" would also work, and uses "static"
+** in the absence of another keyword.
+*/
+#if !defined FICL_PLATFORM_INLINE
+#define FICL_PLATFORM_INLINE static
+#endif /* !defined FICL_PLATFORM_INLINE */
+
+/*
+** FICL_PLATFORM_EXTERN
+** Must be defined, should be a keyword used to declare
+** a function prototype as being a genuine prototype.
+** You should only have to fiddle with this setting if
+** you're not using an ANSI-compliant compiler, in which
+** case, good luck!
+*/
+#if !defined FICL_PLATFORM_EXTERN
+#define FICL_PLATFORM_EXTERN extern
+#endif /* !defined FICL_PLATFORM_EXTERN */
+
+
+
+/*
+** FICL_PLATFORM_BASIC_TYPES
+**
+** If not defined yet,
+*/
+#if !defined(FICL_PLATFORM_BASIC_TYPES)
+typedef char ficlInteger8;
+typedef unsigned char ficlUnsigned8;
+typedef short ficlInteger16;
+typedef unsigned short ficlUnsigned16;
+typedef long ficlInteger32;
+typedef unsigned long ficlUnsigned32;
+
+typedef ficlInteger32 ficlInteger;
+typedef ficlUnsigned32 ficlUnsigned;
+typedef float ficlFloat;
+
+#endif /* !defined(FICL_PLATFORM_BASIC_TYPES) */
+
+
+
+
+
+
+
+/*
+** FICL_ROBUST enables bounds checking of stacks and the dictionary.
+** This will detect stack over and underflows and dictionary overflows.
+** Any exceptional condition will result in an assertion failure.
+** (As generated by the ANSI assert macro)
+** FICL_ROBUST == 1 --> stack checking in the outer interpreter
+** FICL_ROBUST == 2 also enables checking in many primitives
+*/
+
+#if !defined FICL_ROBUST
+#define FICL_ROBUST (2)
+#endif /* FICL_ROBUST */
+
+
+
+/*
+** FICL_DEFAULT_STACK_SIZE Specifies the default size (in CELLs) of
+** a new virtual machine's stacks, unless overridden at
+** create time.
+*/
+#if !defined FICL_DEFAULT_STACK_SIZE
+#define FICL_DEFAULT_STACK_SIZE (128)
+#endif
+
+/*
+** FICL_DEFAULT_DICTIONARY_SIZE specifies the number of ficlCells to allocate
+** for the system dictionary by default. The value
+** can be overridden at startup time as well.
+*/
+#if !defined FICL_DEFAULT_DICTIONARY_SIZE
+#define FICL_DEFAULT_DICTIONARY_SIZE (12288)
+#endif
+
+/*
+** FICL_DEFAULT_ENVIRONMENT_SIZE specifies the number of cells
+** to allot for the environment-query dictionary.
+*/
+#if !defined FICL_DEFAULT_ENVIRONMENT_SIZE
+#define FICL_DEFAULT_ENVIRONMENT_SIZE (512)
+#endif
+
+/*
+** FICL_MAX_WORDLISTS specifies the maximum number of wordlists in
+** the dictionary search order. See Forth DPANS sec 16.3.3
+** (file://dpans16.htm#16.3.3)
+*/
+#if !defined FICL_MAX_WORDLISTS
+#define FICL_MAX_WORDLISTS (16)
+#endif
+
+/*
+** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure
+** that stores pointers to parser extension functions. I would never expect to have
+** more than 8 of these, so that's the default limit. Too many of these functions
+** will probably exact a nasty performance penalty.
+*/
+#if !defined FICL_MAX_PARSE_STEPS
+#define FICL_MAX_PARSE_STEPS (8)
+#endif
+
+/*
+** Maximum number of local variables per definition.
+** This only affects the size of the locals dictionary,
+** and there's only one per entire ficlSystem, so it
+** doesn't make sense to be a piker here.
+*/
+#if (!defined(FICL_MAX_LOCALS)) && FICL_WANT_LOCALS
+#define FICL_MAX_LOCALS (64)
+#endif
+
+/*
+** The pad is a small scratch area for text manipulation. ANS Forth
+** requires it to hold at least 84 characters.
+*/
+#if !defined FICL_PAD_SIZE
+#define FICL_PAD_SIZE (256)
+#endif
+
+/*
+** ANS Forth requires that a word's name contain {1..31} characters.
+*/
+#if !defined FICL_NAME_LENGTH
+#define FICL_NAME_LENGTH (31)
+#endif
+
+/*
+** Default size of hash table. For most uniform
+** performance, use a prime number!
+*/
+#if !defined FICL_HASH_SIZE
+ #define FICL_HASH_SIZE (241)
+#endif
+
+
+/*
+** Default number of USER flags.
+*/
+#if (!defined(FICL_USER_CELLS)) && FICL_WANT_USER
+#define FICL_USER_CELLS (16)
+#endif
+
+
+
+
+
/*
** Forward declarations... read on.
*/
-struct ficl_word;
-typedef struct ficl_word FICL_WORD;
-struct vm;
-typedef struct vm FICL_VM;
-struct ficl_dict;
-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;
+struct ficlWord;
+typedef struct ficlWord ficlWord;
+struct ficlVm;
+typedef struct ficlVm ficlVm;
+struct ficlDictionary;
+typedef struct ficlDictionary ficlDictionary;
+struct ficlSystem;
+typedef struct ficlSystem ficlSystem;
+struct ficlSystemInformation;
+typedef struct ficlSystemInformation ficlSystemInformation;
+struct ficlCallback;
+typedef struct ficlCallback ficlCallback;
+struct ficlCountedString;
+typedef struct ficlCountedString ficlCountedString;
+struct ficlString;
+typedef struct ficlString ficlString;
+
+
+/*
+** System dependent routines:
+** Edit the implementations in your appropriate ficlplatform/ *.c to be
+** compatible with your runtime environment.
+**
+** ficlCallbackDefaultTextOut sends a zero-terminated string to the
+** default output device - used for system error messages.
+**
+** ficlMalloc(), ficlRealloc() and ficlFree() have the same semantics
+** as the functions malloc(), realloc(), and free() from the standard C library.
+*/
+FICL_PLATFORM_EXTERN void ficlCallbackDefaultTextOut(ficlCallback *callback, char *text);
+FICL_PLATFORM_EXTERN void *ficlMalloc (size_t size);
+FICL_PLATFORM_EXTERN void ficlFree (void *p);
+FICL_PLATFORM_EXTERN void *ficlRealloc(void *p, size_t size);
+
+
+
+
+
/*
** the Good Stuff starts here...
*/
-#define FICL_VER "3.03"
+#define FICL_VERSION "4.1.0"
+
#if !defined (FICL_PROMPT)
-#define FICL_PROMPT "ok> "
+#define FICL_PROMPT "ok> "
#endif
/*
@@ -251,76 +648,250 @@ typedef struct ficl_system_info FICL_SYSTEM_INFO;
#define FICL_BOOL(x) ((x) ? FICL_TRUE : FICL_FALSE)
+#if !defined FICL_IGNORE /* Macro to silence unused param warnings */
+#define FICL_IGNORE(x) (void)x
+#endif /* !defined FICL_IGNORE */
+
+
+
+
+#if !defined NULL
+#define NULL ((void *)0)
+#endif
+
+
+/*
+** Jiggery-pokery for the FICL_WANT_COMPATIBILITY compatibility layer.
+** Even if you're not using it, compatibility.c won't compile properly
+** unless FICL_WANT_COMPATIBILITY is turned on. Hence, we force it to
+** always be turned on.
+*/
+#ifdef FICL_FORCE_COMPATIBILITY
+#undef FICL_WANT_COMPATIBILITY
+#define FICL_WANT_COMPATIBILITY (1)
+#endif /* FICL_FORCE_COMPATIBILITY */
+
+
+
+
+
/*
-** A CELL is the main storage type. It must be large enough
+** 2integer structures
+*/
+#if FICL_PLATFORM_HAS_2INTEGER
+
+#define FICL_2INTEGER_SET(high, low, doublei) ((doublei) = (ficl2Integer)(((ficlUnsigned)(low)) | (((ficl2Integer)(high)) << FICL_BITS_PER_CELL)))
+#define FICL_2INTEGER_TO_2UNSIGNED(doublei) ((ficl2Unsigned)(doublei))
+
+#define FICL_2UNSIGNED_SET(high, low, doubleu) ((doubleu) = ((ficl2Unsigned)(low)) | (((ficl2Unsigned)(high)) << FICL_BITS_PER_CELL))
+#define FICL_2UNSIGNED_GET_LOW(doubleu) ((ficlUnsigned)(doubleu & ((((ficl2Integer)1) << FICL_BITS_PER_CELL) - 1)))
+#define FICL_2UNSIGNED_GET_HIGH(doubleu) ((ficlUnsigned)(doubleu >> FICL_BITS_PER_CELL))
+#define FICL_2UNSIGNED_NOT_ZERO(doubleu) ((doubleu) != 0)
+#define FICL_2UNSIGNED_TO_2INTEGER(doubleu) ((ficl2Integer)(doubleu))
+
+#define FICL_INTEGER_TO_2INTEGER(i, doublei) ((doublei) = (i))
+#define FICL_UNSIGNED_TO_2UNSIGNED(u, doubleu) ((doubleu) = (u))
+
+#define ficl2IntegerIsNegative(doublei) ((doublei) < 0)
+#define ficl2IntegerNegate(doublei) (-(doublei))
+
+#define ficl2IntegerMultiply(x, y) (((ficl2Integer)(x)) * ((ficl2Integer)(y)))
+#define ficl2IntegerDecrement(x) (((ficl2Integer)(x)) - 1)
+
+#define ficl2UnsignedAdd(x, y) (((ficl2Unsigned)(x)) + ((ficl2Unsigned)(y)))
+#define ficl2UnsignedSubtract(x, y) (((ficl2Unsigned)(x)) - ((ficl2Unsigned)(y)))
+#define ficl2UnsignedMultiply(x, y) (((ficl2Unsigned)(x)) * ((ficl2Unsigned)(y)))
+#define ficl2UnsignedMultiplyAccumulate(u, mul, add) (((u) * (mul)) + (add))
+#define ficl2UnsignedArithmeticShiftLeft(x) ((x) << 1)
+#define ficl2UnsignedArithmeticShiftRight(x) ((x) >> 1)
+#define ficl2UnsignedCompare(x, y) ficl2UnsignedSubtract(x, y)
+#define ficl2UnsignedOr(x, y) ((x) | (y))
+
+#else /* FICL_PLATFORM_HAS_2INTEGER */
+
+typedef struct
+{
+ ficlUnsigned high;
+ ficlUnsigned low;
+} ficl2Unsigned;
+
+typedef struct
+{
+ ficlInteger high;
+ ficlInteger low;
+} ficl2Integer;
+
+
+#define FICL_2INTEGER_SET(hi, lo, doublei) { ficl2Integer x; x.low = (lo); x.high = (hi); (doublei) = x; }
+#define FICL_2INTEGER_TO_2UNSIGNED(doublei) (*(ficl2Unsigned *)(&(doublei)))
+
+
+#define FICL_2UNSIGNED_SET(hi, lo, doubleu) { ficl2Unsigned x; x.low = (lo); x.high = (hi); (doubleu) = x; }
+#define FICL_2UNSIGNED_GET_LOW(doubleu) ((doubleu).low)
+#define FICL_2UNSIGNED_GET_HIGH(doubleu) ((doubleu).high)
+#define FICL_2UNSIGNED_NOT_ZERO(doubleu) ((doubleu).high || (doubleu).low)
+#define FICL_2UNSIGNED_TO_2INTEGER(doubleu) (*(ficl2Integer *)(&(doubleu)))
+
+#define FICL_INTEGER_TO_2INTEGER(i, doublei) { ficlInteger __x = (ficlInteger)(i); FICL_2INTEGER_SET((__x < 0) ? -1L : 0, __x, doublei) }
+#define FICL_UNSIGNED_TO_2UNSIGNED(u, doubleu) FICL_2UNSIGNED_SET(0, u, doubleu)
+
+
+FICL_PLATFORM_EXTERN int ficl2IntegerIsNegative(ficl2Integer x);
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerNegate(ficl2Integer x);
+
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerMultiply(ficlInteger x, ficlInteger y);
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerDecrement(ficl2Integer x);
+
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedAdd(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedSubtract(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedMultiply(ficlUnsigned x, ficlUnsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedMultiplyAccumulate(ficl2Unsigned u, ficlUnsigned mul, ficlUnsigned add);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedArithmeticShiftLeft( ficl2Unsigned x );
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedArithmeticShiftRight( ficl2Unsigned x );
+FICL_PLATFORM_EXTERN int ficl2UnsignedCompare(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedOr( ficl2Unsigned x, ficl2Unsigned y );
+
+#endif /* FICL_PLATFORM_HAS_2INTEGER */
+
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerAbsoluteValue(ficl2Integer x);
+
+/*
+** These structures represent the result of division.
+*/
+typedef struct
+{
+ ficl2Unsigned quotient;
+ ficlUnsigned remainder;
+} ficl2UnsignedQR;
+
+typedef struct
+{
+ ficl2Integer quotient;
+ ficlInteger remainder;
+} ficl2IntegerQR;
+
+
+#define FICL_2INTEGERQR_TO_2UNSIGNEDQR(doubleiqr) (*(ficl2UnsignedQR *)(&(doubleiqr)))
+#define FICL_2UNSIGNEDQR_TO_2INTEGERQR(doubleuqr) (*(ficl2IntegerQR *)(&(doubleuqr)))
+
+/*
+** 64 bit integer math support routines: multiply two UNS32s
+** to get a 64 bit product, & divide the product by an UNS32
+** to get an UNS32 quotient and remainder. Much easier in asm
+** on a 32 bit CPU than in C, which usually doesn't support
+** the double length result (but it should).
+*/
+FICL_PLATFORM_EXTERN ficl2IntegerQR ficl2IntegerDivideFloored(ficl2Integer num, ficlInteger den);
+FICL_PLATFORM_EXTERN ficl2IntegerQR ficl2IntegerDivideSymmetric(ficl2Integer num, ficlInteger den);
+
+FICL_PLATFORM_EXTERN ficl2UnsignedQR ficl2UnsignedDivide(ficl2Unsigned q, ficlUnsigned y);
+
+
+
+
+
+
+/*
+** A ficlCell is the main storage type. It must be large enough
** to contain a pointer or a scalar. In order to accommodate
** 32 bit and 64 bit processors, use abstract types for int,
** unsigned, and float.
+**
+** A ficlUnsigned, ficlInteger, and ficlFloat *MUST* be the same
+** size as a "void *" on the target system. (Sorry, but that's
+** a design constraint of FORTH.)
*/
-typedef union _cell
+typedef union ficlCell
{
- FICL_INT i;
- FICL_UNS u;
+ ficlInteger i;
+ ficlUnsigned u;
#if (FICL_WANT_FLOAT)
- FICL_FLOAT f;
+ ficlFloat f;
#endif
void *p;
void (*fn)(void);
-} CELL;
+} ficlCell;
+
+
+#define FICL_BITS_PER_CELL (sizeof(ficlCell) * 8)
+
+/*
+** FICL_PLATFORM_ALIGNMENT is the number of bytes to which
+** the dictionary pointer address must be aligned. This value
+** is usually either 2 or 4, depending on the memory architecture
+** of the target system; 4 is safe on any 16 or 32 bit
+** machine. 8 would be appropriate for a 64 bit machine.
+*/
+#if !defined FICL_PLATFORM_ALIGNMENT
+#define FICL_PLATFORM_ALIGNMENT (4)
+#endif
+
/*
-** LVALUEtoCELL does a little pointer trickery to cast any CELL sized
+** FICL_LVALUE_TO_CELL does a little pointer trickery to cast any CELL sized
** lvalue (informal definition: an expression whose result has an
** address) to CELL. Remember that constants and casts are NOT
** themselves lvalues!
*/
-#define LVALUEtoCELL(v) (*(CELL *)&v)
+#define FICL_LVALUE_TO_CELL(v) (*(ficlCell *)&v)
/*
** PTRtoCELL is a cast through void * intended to satisfy the
** most outrageously pedantic compiler... (I won't mention
** its name)
*/
-#define PTRtoCELL (CELL *)(void *)
-#define PTRtoSTRING (FICL_STRING *)(void *)
+#define FICL_POINTER_TO_CELL(p) ((ficlCell *)(void *)p)
/*
-** Strings in FICL are stored in Pascal style - with a count
-** preceding the text. We'll also NULL-terminate them so that
-** they work with the usual C lib string functions. (Belt &
-** suspenders? You decide.)
-** STRINGINFO hides the implementation with a couple of
-** macros for use in internal routines.
+** FORTH defines the "counted string" data type. This is
+** a "Pascal-style" string, where the first byte is an unsigned
+** count of characters, followed by the characters themselves.
+** The Ficl structure for this is ficlCountedString.
+** Ficl also often zero-terminates them so that they work with the
+** usual C runtime library string functions... strlen(), strcmp(),
+** and the like. (Belt & suspenders? You decide.)
+**
+** The problem is, this limits strings to 255 characters, which
+** can be a bit constricting to us wordy types. So FORTH only
+** uses counted strings for backwards compatibility, and all new
+** words are "c-addr u" style, where the address and length are
+** stored separately, and the length is a full unsigned "cell" size.
+** (For more on this trend, see DPANS94 section A.3.1.3.4.)
+** Ficl represents this with the ficlString structure. Note that
+** these are frequently *not* zero-terminated! Don't depend on
+** it--that way lies madness.
*/
-typedef unsigned char FICL_COUNT;
-#define FICL_STRING_MAX UCHAR_MAX
-typedef struct _ficl_string
+struct ficlCountedString
{
- FICL_COUNT count;
+ ficlUnsigned8 length;
char text[1];
-} FICL_STRING;
+};
+
+#define FICL_COUNTED_STRING_GET_LENGTH(cs) ((cs).length)
+#define FICL_COUNTED_STRING_GET_POINTER(cs) ((cs).text)
+
+#define FICL_COUNTED_STRING_MAX (256)
+#define FICL_POINTER_TO_COUNTED_STRING(p) ((ficlCountedString *)(void *)p)
-typedef struct
+struct ficlString
{
- FICL_UNS count;
- char *cp;
-} STRINGINFO;
-
-#define SI_COUNT(si) (si.count)
-#define SI_PTR(si) (si.cp)
-#define SI_SETLEN(si, len) (si.count = (FICL_UNS)(len))
-#define SI_SETPTR(si, ptr) (si.cp = (char *)(ptr))
-/*
-** Init a STRINGINFO from a pointer to NULL-terminated string
-*/
-#define SI_PSZ(si, psz) \
- {si.cp = psz; si.count = (FICL_COUNT)strlen(psz);}
+ ficlUnsigned length;
+ char *text;
+};
+
+
+#define FICL_STRING_GET_LENGTH(fs) ((fs).length)
+#define FICL_STRING_GET_POINTER(fs) ((fs).text)
+#define FICL_STRING_SET_LENGTH(fs, l) ((fs).length = (ficlUnsigned)(l))
+#define FICL_STRING_SET_POINTER(fs, p) ((fs).text = (char *)(p))
+#define FICL_STRING_SET_FROM_COUNTED_STRING(string, countedstring) \
+ {(string).text = (countedstring).text; (string).length = (countedstring).length;}
/*
-** Init a STRINGINFO from a pointer to FICL_STRING
+** Init a FICL_STRING from a pointer to a zero-terminated string
*/
-#define SI_PFS(si, pfs) \
- {si.cp = pfs->text; si.count = pfs->count;}
+#define FICL_STRING_SET_FROM_CSTRING(string, cstring) \
+ {(string).text = (cstring); (string).length = strlen(cstring);}
/*
** Ficl uses this little structure to hold the address of
@@ -334,14 +905,14 @@ typedef struct
** null-terminated string aware functions find most easy to deal
** with.
** Notice, though, that nobody really uses this except evaluate,
-** so it might just be moved to FICL_VM instead. (sobral)
+** so it might just be moved to ficlVm instead. (sobral)
*/
typedef struct
{
- FICL_INT index;
+ ficlInteger index;
char *end;
- char *cp;
-} TIB;
+ char *text;
+} ficlTIB;
/*
@@ -353,70 +924,123 @@ typedef struct
** but not modeled because it doesn't need to be...)
** Here's an abstract type for a stack
*/
-typedef struct _ficlStack
+typedef struct ficlStack
{
- FICL_UNS nCells; /* size of the stack */
- CELL *pFrame; /* link reg for stack frame */
- CELL *sp; /* stack pointer */
- CELL base[1]; /* Top of stack */
-} FICL_STACK;
+ ficlUnsigned size; /* size of the stack, in cells */
+ ficlCell *frame; /* link reg for stack frame */
+ ficlCell *top; /* stack pointer */
+ ficlVm *vm; /* used for debugging */
+ char *name; /* used for debugging */
+ ficlCell base[1]; /* Top of stack */
+} ficlStack;
/*
** Stack methods... many map closely to required Forth words.
*/
-FICL_STACK *stackCreate (unsigned nCells);
-void stackDelete (FICL_STACK *pStack);
-int stackDepth (FICL_STACK *pStack);
-void stackDrop (FICL_STACK *pStack, int n);
-CELL stackFetch (FICL_STACK *pStack, int n);
-CELL stackGetTop (FICL_STACK *pStack);
-void stackLink (FICL_STACK *pStack, int nCells);
-void stackPick (FICL_STACK *pStack, int n);
-CELL stackPop (FICL_STACK *pStack);
-void *stackPopPtr (FICL_STACK *pStack);
-FICL_UNS stackPopUNS (FICL_STACK *pStack);
-FICL_INT stackPopINT (FICL_STACK *pStack);
-void stackPush (FICL_STACK *pStack, CELL c);
-void stackPushPtr (FICL_STACK *pStack, void *ptr);
-void stackPushUNS (FICL_STACK *pStack, FICL_UNS u);
-void stackPushINT (FICL_STACK *pStack, FICL_INT i);
-void stackReset (FICL_STACK *pStack);
-void stackRoll (FICL_STACK *pStack, int n);
-void stackSetTop (FICL_STACK *pStack, CELL c);
-void stackStore (FICL_STACK *pStack, int n, CELL c);
-void stackUnlink (FICL_STACK *pStack);
+FICL_PLATFORM_EXTERN ficlStack *ficlStackCreate (ficlVm *vm, char *name, unsigned nCells);
+FICL_PLATFORM_EXTERN void ficlStackDestroy (ficlStack *stack);
+FICL_PLATFORM_EXTERN int ficlStackDepth (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackDrop (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackFetch (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackGetTop (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPick (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackPop (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPush (ficlStack *stack, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlStackReset (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackRoll (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN void ficlStackSetTop (ficlStack *stack, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlStackStore (ficlStack *stack, int n, ficlCell c);
+
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN void ficlStackLink (ficlStack *stack, int nCells);
+FICL_PLATFORM_EXTERN void ficlStackUnlink (ficlStack *stack);
+#endif /* FICL_WANT_LOCALS */
+
+FICL_PLATFORM_EXTERN void *ficlStackPopPointer (ficlStack *stack);
+FICL_PLATFORM_EXTERN ficlUnsigned ficlStackPopUnsigned (ficlStack *stack);
+FICL_PLATFORM_EXTERN ficlInteger ficlStackPopInteger (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPushPointer (ficlStack *stack, void *ptr);
+FICL_PLATFORM_EXTERN void ficlStackPushUnsigned (ficlStack *stack, ficlUnsigned u);
+FICL_PLATFORM_EXTERN void ficlStackPushInteger (ficlStack *stack, ficlInteger i);
#if (FICL_WANT_FLOAT)
-float stackPopFloat (FICL_STACK *pStack);
-void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f);
+FICL_PLATFORM_EXTERN ficlFloat ficlStackPopFloat (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPushFloat (ficlStack *stack, ficlFloat f);
#endif
+FICL_PLATFORM_EXTERN void ficlStackPush2Integer (ficlStack *stack, ficl2Integer i64);
+FICL_PLATFORM_EXTERN ficl2Integer ficlStackPop2Integer (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPush2Unsigned(ficlStack *stack, ficl2Unsigned u64);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficlStackPop2Unsigned (ficlStack *stack);
+
+
+#if FICL_ROBUST >= 1
+FICL_PLATFORM_EXTERN void ficlStackCheck (ficlStack *stack, int popCells, int pushCells);
+#define FICL_STACK_CHECK(stack, popCells, pushCells) ficlStackCheck(stack, popCells, pushCells)
+#else /* FICL_ROBUST >= 1 */
+#define FICL_STACK_CHECK(stack, popCells, pushCells)
+#endif /* FICL_ROBUST >= 1 */
+
+typedef ficlInteger (*ficlStackWalkFunction)(void *constant, ficlCell *cell);
+FICL_PLATFORM_EXTERN void ficlStackWalk(ficlStack *stack, ficlStackWalkFunction callback, void *context, ficlInteger bottomToTop);
+FICL_PLATFORM_EXTERN void ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, void *context);
+
+
+typedef ficlWord **ficlIp; /* the VM's instruction pointer */
+typedef void (*ficlPrimitive)(ficlVm *vm);
+typedef void (*ficlOutputFunction)(ficlCallback *callback, char *text);
+
+
+/*
+** Each VM has a placeholder for an output function -
+** this makes it possible to have each VM do I/O
+** through a different device. If you specify no
+** ficlOutputFunction, it defaults to ficlCallbackDefaultTextOut.
+**
+** You can also set a specific handler just for errors.
+** If you don't specify one, it defaults to using textOut.
+*/
+
+struct ficlCallback
+{
+ void *context;
+ ficlOutputFunction textOut;
+ ficlOutputFunction errorOut;
+ ficlSystem *system;
+ ficlVm *vm;
+};
+
+FICL_PLATFORM_EXTERN void ficlCallbackTextOut(ficlCallback *callback, char *text);
+FICL_PLATFORM_EXTERN void ficlCallbackErrorOut(ficlCallback *callback, char *text);
+
+/*
+** For backwards compatibility.
+*/
+typedef void (*ficlCompatibilityOutputFunction)(ficlVm *vm, char *text, int newline);
+FICL_PLATFORM_EXTERN void ficlCompatibilityTextOutCallback(ficlCallback *callback, char *text, ficlCompatibilityOutputFunction oldFunction);
+
+
+
/*
-** Shortcuts (Guy Carver)
-*/
-#define PUSHPTR(p) stackPushPtr(pVM->pStack,p)
-#define PUSHUNS(u) stackPushUNS(pVM->pStack,u)
-#define PUSHINT(i) stackPushINT(pVM->pStack,i)
-#define PUSHFLOAT(f) stackPushFloat(pVM->fStack,f)
-#define PUSH(c) stackPush(pVM->pStack,c)
-#define POPPTR() stackPopPtr(pVM->pStack)
-#define POPUNS() stackPopUNS(pVM->pStack)
-#define POPINT() stackPopINT(pVM->pStack)
-#define POPFLOAT() stackPopFloat(pVM->fStack)
-#define POP() stackPop(pVM->pStack)
-#define GETTOP() stackGetTop(pVM->pStack)
-#define SETTOP(c) stackSetTop(pVM->pStack,LVALUEtoCELL(c))
-#define GETTOPF() stackGetTop(pVM->fStack)
-#define SETTOPF(c) stackSetTop(pVM->fStack,LVALUEtoCELL(c))
-#define STORE(n,c) stackStore(pVM->pStack,n,LVALUEtoCELL(c))
-#define DEPTH() stackDepth(pVM->pStack)
-#define DROP(n) stackDrop(pVM->pStack,n)
-#define DROPF(n) stackDrop(pVM->fStack,n)
-#define FETCH(n) stackFetch(pVM->pStack,n)
-#define PICK(n) stackPick(pVM->pStack,n)
-#define PICKF(n) stackPick(pVM->fStack,n)
-#define ROLL(n) stackRoll(pVM->pStack,n)
-#define ROLLF(n) stackRoll(pVM->fStack,n)
+** Starting with Ficl 4.0, Ficl uses a "switch-threaded" inner loop,
+** where each primitive word is represented with a numeric constant,
+** and words are (more or less) arrays of these constants. In Ficl
+** these constants are an enumerated type called ficlInstruction.
+*/
+enum ficlInstruction
+{
+ #define FICL_TOKEN(token, description) token,
+ #define FICL_INSTRUCTION_TOKEN(token, description, flags) token,
+ #include "ficltokens.h"
+ #undef FICL_TOKEN
+ #undef FICL_INSTRUCTION_TOKEN
+
+ ficlInstructionLast,
+
+ ficlInstructionFourByteTrick = 0x10000000
+};
+typedef intptr_t ficlInstruction;
+
/*
** The virtual machine (VM) contains the state for one interpreter.
@@ -430,15 +1054,33 @@ void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f);
** Throw an exception
*/
-typedef FICL_WORD ** IPTYPE; /* the VM's instruction pointer */
-/*
-** Each VM has a placeholder for an output function -
-** this makes it possible to have each VM do I/O
-** through a different device. If you specify no
-** OUTFUNC, it defaults to ficlTextOut.
-*/
-typedef void (*OUTFUNC)(FICL_VM *pVM, char *text, int fNewline);
+struct ficlVm
+{
+ ficlCallback callback;
+ ficlVm *link; /* Ficl keeps a VM list for simple teardown */
+ jmp_buf *exceptionHandler; /* crude exception mechanism... */
+ short restart; /* Set TRUE to restart runningWord */
+ ficlIp ip; /* instruction pointer */
+ ficlWord *runningWord;/* address of currently running word (often just *(ip-1) ) */
+ ficlUnsigned state; /* compiling or interpreting */
+ ficlUnsigned base; /* number conversion base */
+ ficlStack *dataStack;
+ ficlStack *returnStack; /* return stack */
+#if FICL_WANT_FLOAT
+ ficlStack *floatStack; /* float stack (optional) */
+#endif
+ ficlCell sourceId; /* -1 if EVALUATE, 0 if normal input, >0 if a file */
+ ficlTIB tib; /* address of incoming text string */
+#if FICL_WANT_USER
+ ficlCell user[FICL_USER_CELLS];
+#endif
+ char pad[FICL_PAD_SIZE]; /* the scratch area (see above) */
+#if FICL_WANT_COMPATIBILITY
+ ficlCompatibilityOutputFunction thunkedTextout;
+#endif /* FICL_WANT_COMPATIBILITY */
+};
+
/*
** Each VM operates in one of two non-error states: interpreting
@@ -448,51 +1090,141 @@ typedef void (*OUTFUNC)(FICL_VM *pVM, char *text, int fNewline);
** (known as IMMEDIATE) are executed in the compile state, too.
*/
/* values of STATE */
-#define INTERPRET 0
-#define COMPILE 1
+#define FICL_VM_STATE_INTERPRET (0)
+#define FICL_VM_STATE_COMPILE (1)
+
/*
-** The pad is a small scratch area for text manipulation. ANS Forth
-** requires it to hold at least 84 characters.
+** Exit codes for vmThrow
*/
-#if !defined nPAD
-#define nPAD 256
-#endif
+#define FICL_VM_STATUS_INNER_EXIT (-256) /* tell ficlVmExecuteXT to exit inner loop */
+#define FICL_VM_STATUS_OUT_OF_TEXT (-257) /* hungry - normal exit */
+#define FICL_VM_STATUS_RESTART (-258) /* word needs more text to succeed -- re-run it */
+#define FICL_VM_STATUS_USER_EXIT (-259) /* user wants to quit */
+#define FICL_VM_STATUS_ERROR_EXIT (-260) /* interpreter found an error */
+#define FICL_VM_STATUS_BREAK (-261) /* debugger breakpoint */
+#define FICL_VM_STATUS_ABORT ( -1) /* like FICL_VM_STATUS_ERROR_EXIT -- abort */
+#define FICL_VM_STATUS_ABORTQ ( -2) /* like FICL_VM_STATUS_ERROR_EXIT -- abort" */
+#define FICL_VM_STATUS_QUIT ( -56) /* like FICL_VM_STATUS_ERROR_EXIT, but leave dataStack & base alone */
+
+
+FICL_PLATFORM_EXTERN void ficlVmBranchRelative(ficlVm *vm, int offset);
+FICL_PLATFORM_EXTERN ficlVm * ficlVmCreate (ficlVm *vm, unsigned nPStack, unsigned nRStack);
+FICL_PLATFORM_EXTERN void ficlVmDestroy (ficlVm *vm);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlVmGetDictionary(ficlVm *vm);
+FICL_PLATFORM_EXTERN char * ficlVmGetString (ficlVm *vm, ficlCountedString *spDest, char delimiter);
+FICL_PLATFORM_EXTERN ficlString ficlVmGetWord (ficlVm *vm);
+FICL_PLATFORM_EXTERN ficlString ficlVmGetWord0 (ficlVm *vm);
+FICL_PLATFORM_EXTERN int ficlVmGetWordToPad (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmInnerLoop (ficlVm *vm, ficlWord *word);
+FICL_PLATFORM_EXTERN ficlString ficlVmParseString (ficlVm *vm, char delimiter);
+FICL_PLATFORM_EXTERN ficlString ficlVmParseStringEx(ficlVm *vm, char delimiter, char fSkipLeading);
+FICL_PLATFORM_EXTERN ficlCell ficlVmPop (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmPush (ficlVm *vm, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlVmPopIP (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmPushIP (ficlVm *vm, ficlIp newIP);
+FICL_PLATFORM_EXTERN void ficlVmQuit (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmReset (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmSetTextOut (ficlVm *vm, ficlOutputFunction textOut);
+FICL_PLATFORM_EXTERN void ficlVmThrow (ficlVm *vm, int except);
+FICL_PLATFORM_EXTERN void ficlVmThrowError (ficlVm *vm, char *fmt, ...);
+FICL_PLATFORM_EXTERN void ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list);
+FICL_PLATFORM_EXTERN void ficlVmTextOut (ficlVm *vm, char *text);
+FICL_PLATFORM_EXTERN void ficlVmErrorOut (ficlVm *vm, char *text);
+
+#define ficlVmGetContext(vm) ((vm)->context)
+#define ficlVmGetDataStack(vm) ((vm)->dataStack)
+#define ficlVmGetFloatStack(vm) ((vm)->floatStack)
+#define ficlVmGetReturnStack(vm) ((vm)->returnStack)
+#define ficlVmGetRunningWord(vm) ((vm)->runningWord)
+
+FICL_PLATFORM_EXTERN void ficlVmDisplayDataStack(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmDisplayDataStackSimple(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmDisplayReturnStack(ficlVm *vm);
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void ficlVmDisplayFloatStack(ficlVm *vm);
+#endif /* FICL_WANT_FLOAT */
-/*
-** ANS Forth requires that a word's name contain {1..31} characters.
+/*
+** 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.
*/
-#if !defined nFICLNAME
-#define nFICLNAME 31
-#endif
+FICL_PLATFORM_EXTERN int ficlVmEvaluate(ficlVm *vm, char *s);
/*
-** OK - now we can really define the VM...
+** f i c l V m E x e c *
+** Evaluates a block of input text in the context of the
+** specified interpreter. Emits any requested output to the
+** interpreter's output function. If the input string is NULL
+** terminated, you can pass -1 as nChars rather than count it.
+** Execution returns when the text block has been executed,
+** or an error occurs.
+** Returns one of the FICL_VM_STATUS_... codes defined in ficl.h:
+** FICL_VM_STATUS_OUT_OF_TEXT is the normal exit condition
+** FICL_VM_STATUS_ERROR_EXIT means that the interpreter encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** FICL_VM_STATUS_USER_EXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
+** FICL_VM_STATUS_ABORT and FICL_VM_STATUS_ABORTQ are generated by 'abort' and 'abort"'
+** commands.
+** Preconditions: successful execution of ficlInitSystem,
+** Successful creation and init of the VM by ficlNewVM (or equivalent)
+**
+** If you call ficlExec() or one of its brothers, you MUST
+** ensure vm->sourceId was set to a sensible value.
+** ficlExec() explicitly DOES NOT manage SOURCE-ID for you.
*/
-struct vm
-{
- FICL_SYSTEM *pSys; /* Which system this VM belongs to */
- FICL_VM *link; /* Ficl keeps a VM list for simple teardown */
- jmp_buf *pState; /* crude exception mechanism... */
- OUTFUNC textOut; /* Output callback - see sysdep.c */
- void * pExtend; /* vm extension pointer for app use - initialized from FICL_SYSTEM */
- short fRestart; /* Set TRUE to restart runningWord */
- IPTYPE ip; /* instruction pointer */
- FICL_WORD *runningWord;/* address of currently running word (often just *(ip-1) ) */
- FICL_UNS state; /* compiling or interpreting */
- FICL_UNS base; /* number conversion base */
- FICL_STACK *pStack; /* param stack */
- FICL_STACK *rStack; /* return stack */
-#if FICL_WANT_FLOAT
- FICL_STACK *fStack; /* float stack (optional) */
-#endif
- 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];
-#endif
- char pad[nPAD]; /* the scratch area (see above) */
-};
+FICL_PLATFORM_EXTERN int ficlVmExecuteString(ficlVm *vm, ficlString s);
+FICL_PLATFORM_EXTERN int ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord);
+FICL_PLATFORM_EXTERN void ficlVmExecuteInstruction(ficlVm *vm, ficlInstruction i);
+FICL_PLATFORM_EXTERN void ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord);
+
+FICL_PLATFORM_EXTERN void ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n);
+FICL_PLATFORM_EXTERN void ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells);
+
+FICL_PLATFORM_EXTERN int ficlVmParseWord(ficlVm *vm, ficlString s);
+
+
+
+/*
+** TIB access routines...
+** ANS forth seems to require the input buffer to be represented
+** as a pointer to the start of the buffer, and an index to the
+** next character to read.
+** PushTib points the VM to a new input string and optionally
+** returns a copy of the current state
+** PopTib restores the TIB state given a saved TIB from PushTib
+** GetInBuf returns a pointer to the next unused char of the TIB
+*/
+FICL_PLATFORM_EXTERN void ficlVmPushTib (ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib);
+FICL_PLATFORM_EXTERN void ficlVmPopTib (ficlVm *vm, ficlTIB *pTib);
+#define ficlVmGetInBuf(vm) ((vm)->tib.text + (vm)->tib.index)
+#define ficlVmGetInBufLen(vm) ((vm)->tib.end - (vm)->tib.text)
+#define ficlVmGetInBufEnd(vm) ((vm)->tib.end)
+#define ficlVmGetTibIndex(vm) ((vm)->tib.index)
+#define ficlVmSetTibIndex(vm, i) ((vm)->tib.index = i)
+#define ficlVmUpdateTib(vm, str) ((vm)->tib.index = (str) - (vm)->tib.text)
+
+#if FICL_ROBUST >= 1
+ FICL_PLATFORM_EXTERN void ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int n);
+ FICL_PLATFORM_EXTERN void ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int n);
+ #define FICL_VM_DICTIONARY_CHECK(vm, dictionary, n) ficlVmDictionaryCheck(vm, dictionary, n)
+ #define FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n) ficlVmDictionarySimpleCheck(vm, dictionary, n)
+#else
+ #define FICL_VM_DICTIONARY_CHECK(vm, dictionary, n)
+ #define FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n)
+#endif /* FICL_ROBUST >= 1 */
+
+
+
+FICL_PLATFORM_EXTERN void ficlPrimitiveLiteralIm(ficlVm *vm);
/*
** A FICL_CODE points to a function that gets called to help execute
@@ -505,167 +1237,124 @@ struct vm
** may also contain inline data. The first parameter is always
** a pointer to a code field.
*/
-typedef void (*FICL_CODE)(FICL_VM *pVm);
-#if 0
-#define VM_ASSERT(pVM) assert((*(pVM->ip - 1)) == pVM->runningWord)
-#else
-#define VM_ASSERT(pVM)
-#endif
/*
** Ficl models memory as a contiguous space divided into
** words in a linked list called the dictionary.
-** A FICL_WORD starts each entry in the list.
+** A ficlWord starts each entry in the list.
** Version 1.02: space for the name characters is allotted from
** the dictionary ahead of the word struct, rather than using
** a fixed size array for each name.
*/
-struct ficl_word
+struct ficlWord
{
- struct ficl_word *link; /* Previous word in the dictionary */
- UNS16 hash;
- UNS8 flags; /* Immediate, Smudge, Compile-only */
- FICL_COUNT nName; /* Number of chars in word name */
+ struct ficlWord *link; /* Previous word in the dictionary */
+ ficlUnsigned16 hash;
+ ficlUnsigned8 flags; /* Immediate, Smudge, Compile-only, IsOjbect, Instruction */
+ ficlUnsigned8 length; /* Number of chars in word name */
char *name; /* First nFICLNAME chars of word name */
- FICL_CODE code; /* Native code to execute the word */
- CELL param[1]; /* First data cell of the word */
+ ficlPrimitive code; /* Native code to execute the word */
+ ficlInstruction semiParen; /* Native code to execute the word */
+ ficlCell param[1]; /* First data cell of the word */
};
/*
-** Worst-case size of a word header: nFICLNAME chars in name
+** ficlWord.flag bitfield values:
*/
-#define CELLS_PER_WORD \
- ( (sizeof (FICL_WORD) + nFICLNAME + sizeof (CELL)) \
- / (sizeof (CELL)) )
-int wordIsImmediate(FICL_WORD *pFW);
-int wordIsCompileOnly(FICL_WORD *pFW);
+/*
+** FICL_WORD_IMMEDIATE:
+** This word is always executed immediately when
+** encountered, even when compiling.
+*/
+#define FICL_WORD_IMMEDIATE ( 1)
-/* flag values for word header */
-#define FW_IMMEDIATE 1 /* execute me even if compiling */
-#define FW_COMPILE 2 /* error if executed when not compiling */
-#define FW_SMUDGE 4 /* definition in progress - hide me */
-#define FW_ISOBJECT 8 /* word is an object or object member variable */
+/*
+** FICL_WORD_COMPILE_ONLY:
+** This word is only valid during compilation.
+** Ficl will throw a runtime error if this word executed
+** while not compiling.
+*/
+#define FICL_WORD_COMPILE_ONLY ( 2)
-#define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE)
-#define FW_DEFAULT 0
+/*
+** FICL_WORD_SMUDGED
+** This word's definition is in progress.
+** The word is hidden from dictionary lookups
+** until it is "un-smudged".
+*/
+#define FICL_WORD_SMUDGED ( 4)
+/*
+** FICL_WORD_OBJECT
+** This word is an object or object member variable.
+** (Currently only used by "my=[".)
+*/
+#define FICL_WORD_OBJECT ( 8)
/*
-** Exit codes for vmThrow
+** FICL_WORD_INSTRUCTION
+** This word represents a ficlInstruction, not a normal word.
+** param[0] is the instruction.
+** When compiled, Ficl will simply copy over the instruction,
+** rather than executing the word as normal.
+**
+** (Do *not* use this flag for words that need their PFA pushed
+** before executing!)
*/
-#define VM_INNEREXIT -256 /* tell ficlExecXT to exit inner loop */
-#define VM_OUTOFTEXT -257 /* hungry - normal exit */
-#define VM_RESTART -258 /* word needs more text to succeed - re-run it */
-#define VM_USEREXIT -259 /* user wants to quit */
-#define VM_ERREXIT -260 /* interp found an error */
-#define VM_BREAK -261 /* debugger breakpoint */
-#define VM_ABORT -1 /* like errexit -- abort */
-#define VM_ABORTQ -2 /* like errexit -- abort" */
-#define VM_QUIT -56 /* like errexit, but leave pStack & base alone */
-
-
-void vmBranchRelative(FICL_VM *pVM, int offset);
-FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack);
-void vmDelete (FICL_VM *pVM);
-void vmExecute (FICL_VM *pVM, FICL_WORD *pWord);
-FICL_DICT *vmGetDict (FICL_VM *pVM);
-char * vmGetString (FICL_VM *pVM, FICL_STRING *spDest, char delimiter);
-STRINGINFO vmGetWord (FICL_VM *pVM);
-STRINGINFO vmGetWord0 (FICL_VM *pVM);
-int vmGetWordToPad (FICL_VM *pVM);
-STRINGINFO vmParseString (FICL_VM *pVM, char delimiter);
-STRINGINFO vmParseStringEx(FICL_VM *pVM, char delimiter, char fSkipLeading);
-CELL vmPop (FICL_VM *pVM);
-void vmPush (FICL_VM *pVM, CELL c);
-void vmPopIP (FICL_VM *pVM);
-void vmPushIP (FICL_VM *pVM, IPTYPE newIP);
-void vmQuit (FICL_VM *pVM);
-void vmReset (FICL_VM *pVM);
-void vmSetTextOut (FICL_VM *pVM, OUTFUNC textOut);
-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, ...);
-
-#define vmGetRunningWord(pVM) ((pVM)->runningWord)
-
-
-/*
-** The inner interpreter - coded as a macro (see note for
-** INLINE_INNER_LOOP in sysdep.h for complaints about VC++ 5
-*/
-#define M_VM_STEP(pVM) \
- FICL_WORD *tempFW = *(pVM)->ip++; \
- (pVM)->runningWord = tempFW; \
- tempFW->code(pVM);
-
-#define M_INNER_LOOP(pVM) \
- for (;;) { M_VM_STEP(pVM) }
-
-
-#if INLINE_INNER_LOOP != 0
-#define vmInnerLoop(pVM) M_INNER_LOOP(pVM)
-#else
-void vmInnerLoop(FICL_VM *pVM);
-#endif
+#define FICL_WORD_INSTRUCTION (16)
/*
-** vmCheckStack needs a vm pointer because it might have to say
-** something if it finds a problem. Parms popCells and pushCells
-** correspond to the number of parameters on the left and right of
-** a word's stack effect comment.
+** FICL_WORD_COMPILE_ONLY_IMMEDIATE
+** Most words that are "immediate" are also
+** "compile-only".
*/
-void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
-#if FICL_WANT_FLOAT
-void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells);
-#endif
+#define FICL_WORD_COMPILE_ONLY_IMMEDIATE (FICL_WORD_IMMEDIATE | FICL_WORD_COMPILE_ONLY)
+#define FICL_WORD_DEFAULT ( 0)
+
/*
-** TIB access routines...
-** ANS forth seems to require the input buffer to be represented
-** as a pointer to the start of the buffer, and an index to the
-** next character to read.
-** PushTib points the VM to a new input string and optionally
-** returns a copy of the current state
-** PopTib restores the TIB state given a saved TIB from PushTib
-** GetInBuf returns a pointer to the next unused char of the TIB
+** Worst-case size of a word header: FICL_NAME_LENGTH chars in name
*/
-void vmPushTib (FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib);
-void vmPopTib (FICL_VM *pVM, TIB *pTib);
-#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
-#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp)
-#define vmGetInBufEnd(pVM) ((pVM)->tib.end)
-#define vmGetTibIndex(pVM) (pVM)->tib.index
-#define vmSetTibIndex(pVM, i) (pVM)->tib.index = i
-#define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp
+#define FICL_CELLS_PER_WORD \
+ ( (sizeof (ficlWord) + FICL_NAME_LENGTH + sizeof (ficlCell)) \
+ / (sizeof (ficlCell)) )
+
+FICL_PLATFORM_EXTERN int ficlWordIsImmediate(ficlWord *word);
+FICL_PLATFORM_EXTERN int ficlWordIsCompileOnly(ficlWord *word);
+
+
+
+
+#if FICL_ROBUST >= 1
+ FICL_PLATFORM_EXTERN void ficlCallbackAssert(ficlCallback *callback, int expression, char *expressionString, char *filename, int line);
+ #define FICL_ASSERT(callback, expression) (ficlCallbackAssert((callback), (expression) != 0, #expression, __FILE__, __LINE__))
+#else
+ #define FICL_ASSERT(callback, expression)
+#endif /* FICL_ROBUST >= 1 */
+
+#define FICL_VM_ASSERT(vm, expression) FICL_ASSERT((ficlCallback *)(vm), (expression))
+#define FICL_SYSTEM_ASSERT(system, expression) FICL_ASSERT((ficlCallback *)(system), (expression))
+
+
/*
** Generally useful string manipulators omitted by ANSI C...
** ltoa complements strtol
*/
-#if defined(_WIN32) && !FICL_MAIN
-/* #SHEESH
-** Why do Microsoft Meatballs insist on contaminating
-** my namespace with their string functions???
-*/
-#pragma warning(disable: 4273)
-#endif
-int isPowerOfTwo(FICL_UNS u);
+FICL_PLATFORM_EXTERN int ficlIsPowerOfTwo(ficlUnsigned u);
-char *ltoa( FICL_INT value, char *string, int radix );
-char *ultoa(FICL_UNS value, char *string, int radix );
-char digit_to_char(int value);
-char *strrev( char *string );
-char *skipSpace(char *cp, char *end);
-char *caseFold(char *cp);
-int strincmp(char *cp1, char *cp2, FICL_UNS count);
+FICL_PLATFORM_EXTERN char *ficlLtoa(ficlInteger value, char *string, int radix );
+FICL_PLATFORM_EXTERN char *ficlUltoa(ficlUnsigned value, char *string, int radix );
+FICL_PLATFORM_EXTERN char ficlDigitToCharacter(int value);
+FICL_PLATFORM_EXTERN char *ficlStringReverse( char *string );
+FICL_PLATFORM_EXTERN char *ficlStringSkipSpace(char *s, char *end);
+FICL_PLATFORM_EXTERN char *ficlStringCaseFold(char *s);
+FICL_PLATFORM_EXTERN int ficlStrincmp(char *s1, char *s2, ficlUnsigned length);
+FICL_PLATFORM_EXTERN void *ficlAlignPointer(void *ptr);
-#if defined(_WIN32) && !FICL_MAIN
-#pragma warning(default: 4273)
-#endif
/*
** Ficl hash table - variable size.
@@ -674,23 +1363,20 @@ int strincmp(char *cp1, char *cp2, FICL_UNS count);
** A WORDLIST (see the search order word set in DPANS) is
** just a pointer to a FICL_HASH in this implementation.
*/
-#if !defined HASHSIZE /* Default size of hash table. For most uniform */
-#define HASHSIZE 241 /* performance, use a prime number! */
-#endif
-typedef struct ficl_hash
+typedef struct ficlHash
{
- struct ficl_hash *link; /* link to parent class wordlist for OO */
+ struct ficlHash *link; /* link to parent class wordlist for OO */
char *name; /* optional pointer to \0 terminated wordlist name */
unsigned size; /* number of buckets in the hash */
- FICL_WORD *table[1];
-} FICL_HASH;
+ ficlWord *table[1];
+} ficlHash;
-void hashForget (FICL_HASH *pHash, void *where);
-UNS16 hashHashCode (STRINGINFO si);
-void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW);
-FICL_WORD *hashLookup (FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode);
-void hashReset (FICL_HASH *pHash);
+FICL_PLATFORM_EXTERN void ficlHashForget (ficlHash *hash, void *where);
+FICL_PLATFORM_EXTERN ficlUnsigned16 ficlHashCode (ficlString s);
+FICL_PLATFORM_EXTERN void ficlHashInsertWord(ficlHash *hash, ficlWord *word);
+FICL_PLATFORM_EXTERN ficlWord *ficlHashLookup (ficlHash *hash, ficlString name, ficlUnsigned16 hashCode);
+FICL_PLATFORM_EXTERN void ficlHashReset (ficlHash *hash);
/*
** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's
@@ -706,79 +1392,141 @@ void hashReset (FICL_HASH *pHash);
** uses this pointer to restore the previous state of the dictionary.
** Smudge prevents unintentional recursion as a side-effect: the
** dictionary search algo examines only completed definitions, so a
-** word cannot invoke itself by name. See the ficl word "recurse".
+** word cannot invoke itself by name. See the Ficl word "recurse".
** NOTE: smudge always points to the last word defined. IMMEDIATE
** makes use of this fact. Smudge is initially NULL.
**
-** pForthWords -- pointer to the default wordlist (FICL_HASH).
+** forthWordlist -- pointer to the default wordlist (FICL_HASH).
** This is the initial compilation list, and contains all
-** ficl's precompiled words.
+** Ficl's precompiled words.
**
-** pCompile -- compilation wordlist - initially equal to pForthWords
-** pSearch -- array of pointers to wordlists. Managed as a stack.
+** compilationWordlist -- compilation wordlist - initially equal to forthWordlist
+** wordlists -- array of pointers to wordlists. Managed as a stack.
** Highest index is the first list in the search order.
-** nLists -- number of lists in pSearch. nLists-1 is the highest
-** filled slot in pSearch, and points to the first wordlist
+** wordlistCount -- number of lists in wordlists. wordlistCount-1 is the highest
+** filled slot in wordlists, and points to the first wordlist
** in the search order
** size -- number of cells in the dictionary (total)
-** dict -- start of data area. Must be at the end of the struct.
+** base -- start of data area. Must be at the end of the struct.
*/
-struct ficl_dict
+struct ficlDictionary
{
- CELL *here;
- FICL_WORD *smudge;
- FICL_HASH *pForthWords;
- FICL_HASH *pCompile;
- FICL_HASH *pSearch[FICL_DEFAULT_VOCS];
- int nLists;
- unsigned size; /* Number of cells in dict (total)*/
- CELL dict[1]; /* Base of dictionary memory */
+ ficlCell *here;
+ void *context; /* for your use, particularly with ficlDictionaryLock() */
+ ficlWord *smudge;
+ ficlHash *forthWordlist;
+ ficlHash *compilationWordlist;
+ ficlHash *wordlists[FICL_MAX_WORDLISTS];
+ int wordlistCount;
+ unsigned size; /* Number of cells in dictionary (total)*/
+ ficlSystem *system; /* used for debugging */
+ ficlCell base[1]; /* Base of dictionary memory */
};
-void *alignPtr(void *ptr);
-void dictAbortDefinition(FICL_DICT *pDict);
-void dictAlign (FICL_DICT *pDict);
-int dictAllot (FICL_DICT *pDict, int n);
-int dictAllotCells (FICL_DICT *pDict, int nCells);
-void dictAppendCell (FICL_DICT *pDict, CELL c);
-void dictAppendChar (FICL_DICT *pDict, char c);
-FICL_WORD *dictAppendWord (FICL_DICT *pDict,
+FICL_PLATFORM_EXTERN void ficlDictionaryAbortDefinition(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryAlign (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryAllot (ficlDictionary *dictionary, int n);
+FICL_PLATFORM_EXTERN void ficlDictionaryAllotCells (ficlDictionary *dictionary, int nCells);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendCell (ficlDictionary *dictionary, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendCharacter(ficlDictionary *dictionary, char c);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendUnsigned(ficlDictionary *dictionary, ficlUnsigned u);
+FICL_PLATFORM_EXTERN void *ficlDictionaryAppendData(ficlDictionary *dictionary, void *data, ficlInteger length);
+FICL_PLATFORM_EXTERN char *ficlDictionaryAppendString(ficlDictionary *dictionary, ficlString s);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendWord(ficlDictionary *dictionary,
+ ficlString name,
+ ficlPrimitive pCode,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendPrimitive(ficlDictionary *dictionary,
char *name,
- FICL_CODE pCode,
- UNS8 flags);
-FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
- STRINGINFO si,
- FICL_CODE pCode,
- UNS8 flags);
-void dictAppendUNS (FICL_DICT *pDict, FICL_UNS u);
-int dictCellsAvail (FICL_DICT *pDict);
-int dictCellsUsed (FICL_DICT *pDict);
-void dictCheck (FICL_DICT *pDict, FICL_VM *pVM, int n);
-FICL_DICT *dictCreate(unsigned nCELLS);
-FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash);
-FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets);
-void dictDelete (FICL_DICT *pDict);
-void dictEmpty (FICL_DICT *pDict, unsigned nHash);
+ ficlPrimitive pCode,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppend2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendConstant(ficlDictionary *dictionary, char *name, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppend2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value);
+#define ficlDictionaryAppendConstantPointer(dictionary, name, pointer) \
+ (ficlDictionaryAppendConstant(dictionary, name, (ficlInteger)pointer))
#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
-FICL_WORD *ficlLookupLoc (FICL_SYSTEM *pSys, STRINGINFO si);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name, float value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name, double value);
+#endif /* FICL_WANT_FLOAT */
+
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySet2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstant(ficlDictionary *dictionary, char *name, ficlInteger value);
+#define ficlDictionarySetConstantPointer(dictionary, name, pointer) \
+ (ficlDictionarySetConstant(dictionary, name, (ficlInteger)pointer))
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySet2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstantString(ficlDictionary *dictionary, char *name, char *value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags);
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name, float value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name, double value);
+#endif /* FICL_WANT_FLOAT */
+
+FICL_PLATFORM_EXTERN int ficlDictionaryCellsAvailable (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN int ficlDictionaryCellsUsed (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlDictionaryCreate(ficlSystem *system, unsigned nCELLS);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlDictionaryCreateHashed(ficlSystem *system, unsigned nCells, unsigned nHash);
+FICL_PLATFORM_EXTERN ficlHash *ficlDictionaryCreateWordlist(ficlDictionary *dictionary, int nBuckets);
+FICL_PLATFORM_EXTERN void ficlDictionaryDestroy (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryEmpty (ficlDictionary *dictionary, unsigned nHash);
+FICL_PLATFORM_EXTERN int ficlDictionaryIncludes (ficlDictionary *dictionary, void *p);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryLookup (ficlDictionary *dictionary, ficlString name);
+FICL_PLATFORM_EXTERN void ficlDictionaryResetSearchOrder(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionarySetFlags (ficlDictionary *dictionary, ficlUnsigned8 set);
+FICL_PLATFORM_EXTERN void ficlDictionaryClearFlags(ficlDictionary *dictionary, ficlUnsigned8 clear);
+FICL_PLATFORM_EXTERN void ficlDictionarySetImmediate(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryUnsmudge (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN ficlCell *ficlDictionaryWhere (ficlDictionary *dictionary);
+
+FICL_PLATFORM_EXTERN int ficlDictionaryIsAWord(ficlDictionary *dictionary, ficlWord *word);
+FICL_PLATFORM_EXTERN void ficlDictionarySee(ficlDictionary *dictionary, ficlWord *word, ficlCallback *callback);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryFindEnclosingWord(ficlDictionary *dictionary, ficlCell *cell);
+
+/*
+** Stub function for dictionary access control - does nothing
+** by default, user can redefine to guarantee exclusive dictionary
+** access to a single thread for updates. All dictionary update code
+** must be bracketed as follows:
+** ficlLockDictionary(dictionary, FICL_TRUE); // any non-zero value will do
+** <code that updates dictionary>
+** ficlLockDictionary(dictionary, FICL_FALSE);
+**
+** Returns zero if successful, nonzero if unable to acquire lock
+** before timeout (optional - could also block forever)
+**
+** NOTE: this function must be implemented with lock counting
+** semantics: nested calls must behave properly.
+*/
+#if FICL_MULTITHREAD
+FICL_PLATFORM_EXTERN int ficlDictionaryLock(ficlDictionary *dictionary, short lockIncrement);
+#else
+#define ficlDictionaryLock(dictionary, lock) (void)0 /* ignore */
#endif
-void dictResetSearchOrder(FICL_DICT *pDict);
-void dictSetFlags (FICL_DICT *pDict, UNS8 set, UNS8 clr);
-void dictSetImmediate(FICL_DICT *pDict);
-void dictUnsmudge (FICL_DICT *pDict);
-CELL *dictWhere (FICL_DICT *pDict);
+
/*
** P A R S E S T E P
** (New for 2.05)
** See words.c: interpWord
-** By default, ficl goes through two attempts to parse each token from its input
+** By default, Ficl goes through two attempts to parse each token from its input
** stream: it first attempts to match it with a word in the dictionary, and
** if that fails, it attempts to convert it into a number. This mechanism is now
** extensible by additional steps. This allows extensions like floating point and
@@ -794,179 +1542,108 @@ CELL *dictWhere (FICL_DICT *pDict);
** do not match as quickly as possible.
*/
-typedef int (*FICL_PARSE_STEP)(FICL_VM *pVM, STRINGINFO si);
-
-/*
-** Appends a parse step function to the end of the parse list (see
-** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
-** nonzero if there's no more room in the list. Each parse step is a word in
-** the dictionary. Precompiled parse steps can use (PARSE-STEP) as their
-** CFA - see parenParseStep in words.c.
-*/
-int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW); /* ficl.c */
-void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep);
-void ficlListParseSteps(FICL_VM *pVM);
+typedef int (*ficlParseStep)(ficlVm *vm, ficlString s);
/*
** FICL_BREAKPOINT record.
-** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
+** oldXT - 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
+** oldXT - The original contents of the location with the breakpoint
** Note: address is NULL when this breakpoint is empty
*/
-typedef struct FICL_BREAKPOINT
+typedef struct ficlBreakpoint
{
void *address;
- FICL_WORD *origXT;
-} FICL_BREAKPOINT;
+ ficlWord *oldXT;
+} ficlBreakpoint;
/*
** 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
-** support multiple Ficl systems, allowing multiple concurrent sessions
+** virtual machines with their corresponding dictionaries. Ficl 3.0 added
+** support for multiple Ficl systems, allowing multiple concurrent sessions
** to separate dictionaries with some constraints.
-** The present model allows multiple sessions to one dictionary provided
-** you implement ficlLockDictionary() as specified in sysdep.h
-** Note: the pExtend pointer is there to provide context for applications. It is copied
-** to each VM's pExtend field as that VM is created.
+** Note: the context pointer is there to provide context for applications. It is copied
+** to each VM's context field as that VM is created.
*/
-struct ficl_system
+struct ficlSystemInformation
{
- FICL_SYSTEM *link;
- void *pExtend; /* Initializes VM's pExtend pointer (for application use) */
- FICL_VM *vmList;
- FICL_DICT *dp;
- FICL_DICT *envp;
-#ifdef FICL_WANT_LOCALS
- FICL_DICT *localp;
-#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 *pBranch0;
- FICL_WORD *pInterpret;
- FICL_WORD *pLitParen;
- FICL_WORD *pTwoLitParen;
- FICL_WORD *pLoopParen;
- FICL_WORD *pPLoopParen;
- FICL_WORD *pQDoParen;
- FICL_WORD *pSemiParen;
- FICL_WORD *pOfParen;
- FICL_WORD *pStore;
- FICL_WORD *pDrop;
- FICL_WORD *pCStringLit;
- FICL_WORD *pStringLit;
+ int size; /* structure size tag for versioning */
+ void *context; /* Initializes VM's context pointer - for application use */
+ int dictionarySize; /* Size of system's Dictionary, in cells */
+ int stackSize; /* Size of all stacks created, in cells */
+ ficlOutputFunction textOut; /* default textOut function */
+ ficlOutputFunction errorOut; /* textOut function used for errors */
+ int environmentSize; /* Size of Environment dictionary, in cells */
+};
+
+#define ficlSystemInformationInitialize(x) { memset((x), 0, sizeof(ficlSystemInformation)); \
+ (x)->size = sizeof(ficlSystemInformation); }
+
+
+
+
+struct ficlSystem
+{
+ ficlCallback callback;
+ ficlSystem *link;
+ ficlVm *vmList;
+ ficlDictionary *dictionary;
+ ficlDictionary *environment;
+
+ ficlWord *interpreterLoop[3];
+ ficlWord *parseList[FICL_MAX_PARSE_STEPS];
+
+ ficlWord *exitInnerWord;
+ ficlWord *interpretWord;
#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;
+ ficlDictionary *locals;
+ ficlInteger localsCount;
+ ficlCell *localsFixup;
#endif
- FICL_BREAKPOINT bpStep;
-};
+ ficlInteger stackSize;
-struct ficl_system_info
-{
- int size; /* structure size tag for versioning */
- int nDictCells; /* Size of system's Dictionary */
- OUTFUNC textOut; /* default textOut function */
- void *pExtend; /* Initializes VM's pExtend pointer - for application use */
- int nEnvCells; /* Size of Environment dictionary */
+ ficlBreakpoint breakpoint;
+#if FICL_WANT_COMPATIBILITY
+ ficlCompatibilityOutputFunction thunkedTextout;
+#endif /* FICL_WANT_COMPATIBILITY */
};
-#define ficlInitInfo(x) { memset((x), 0, sizeof(FICL_SYSTEM_INFO)); \
- (x)->size = sizeof(FICL_SYSTEM_INFO); }
+#define ficlSystemGetContext(system) ((system)->context)
+
/*
-** External interface to FICL...
+** External interface to Ficl...
*/
/*
-** f i c l I n i t S y s t e m
+** f i c l S y s t e m C r e a t e
** Binds a global dictionary to the interpreter system and initializes
-** the dict to contain the ANSI CORE wordset.
+** the dictionary to contain the ANSI CORE wordset.
** 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.
+** You can also specify the text output function at creation time.
+** 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.
** The dictionary needs to be at least large enough to hold the
** 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);
+FICL_PLATFORM_EXTERN ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi);
/*
-** f i c l T e r m S y s t e m
+** f i c l S y s t e m D e s t r o y
** Deletes the system dictionary and all virtual machines that
** were created with ficlNewVM (see below). Call this function to
** reclaim all memory used by the dictionary and VMs.
*/
-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
-** interpreter's output function. If the input string is NULL
-** terminated, you can pass -1 as nChars rather than count it.
-** Execution returns when the text block has been executed,
-** or an error occurs.
-** Returns one of the VM_XXXX codes defined in ficl.h:
-** VM_OUTOFTEXT is the normal exit condition
-** VM_ERREXIT means that the interp encountered a syntax error
-** and the vm has been reset to recover (some or all
-** of the text block got ignored
-** VM_USEREXIT means that the user executed the "bye" command
-** to shut down the interpreter. This would be a good
-** time to delete the vm, etc -- or you can ignore this
-** signal.
-** VM_ABORT and VM_ABORTQ are generated by 'abort' and 'abort"'
-** commands.
-** Preconditions: successful execution of ficlInitSystem,
-** Successful creation and init of the VM by ficlNewVM (or equiv)
-**
-** 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);
-int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord);
+FICL_PLATFORM_EXTERN void ficlSystemDestroy(ficlSystem *system);
/*
** Create a new VM from the heap, and link it into the system VM list.
@@ -974,7 +1651,7 @@ int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord);
** address of the VM, or NULL if an error occurs.
** Precondition: successful execution of ficlInitSystem
*/
-FICL_VM *ficlNewVM(FICL_SYSTEM *pSys);
+FICL_PLATFORM_EXTERN ficlVm *ficlSystemCreateVm(ficlSystem *system);
/*
** Force deletion of a VM. You do not need to do this
@@ -983,113 +1660,116 @@ FICL_VM *ficlNewVM(FICL_SYSTEM *pSys);
** of the system, ficltermSystem takes care of VM cleanup
** automatically.
*/
-void ficlFreeVM(FICL_VM *pVM);
-
+FICL_PLATFORM_EXTERN void ficlSystemDestroyVm(ficlVm *vm);
-/*
-** Set the stack sizes (return and parameter) to be used for all
-** subsequently created VMs. Returns actual stack size to be used.
-*/
-int ficlSetStackSize(int nStackCells);
/*
** Returns the address of the most recently defined word in the system
** dictionary with the given name, or NULL if no match.
** Precondition: successful execution of ficlInitSystem
*/
-FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name);
+FICL_PLATFORM_EXTERN ficlWord *ficlSystemLookup(ficlSystem *system, char *name);
/*
** f i c l G e t D i c t
** Utility function - returns the address of the system dictionary.
** Precondition: successful execution of ficlInitSystem
*/
-FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys);
-FICL_DICT *ficlGetEnv (FICL_SYSTEM *pSys);
-void ficlSetEnv (FICL_SYSTEM *pSys, char *name, FICL_UNS value);
-void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo);
+ficlDictionary *ficlSystemGetDictionary(ficlSystem *system);
+ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system);
#if FICL_WANT_LOCALS
-FICL_DICT *ficlGetLoc (FICL_SYSTEM *pSys);
+ficlDictionary *ficlSystemGetLocals(ficlSystem *system);
#endif
-/*
-** f i c l B u i l d
-** Builds a word into the system default dictionary in a thread-safe way.
-** Preconditions: system must be initialized, and there must
-** be enough space for the new word's header! Operation is
-** controlled by ficlLockDictionary, so any initialization
-** required by your version of the function (if you "overrode"
-** it) must be complete at this point.
-** Parameters:
-** name -- the name of the word to be built
-** code -- code to execute when the word is invoked - must take a single param
-** pointer to a FICL_VM
-** flags -- 0 or more of FW_IMMEDIATE, FW_COMPILE, use bitwise OR!
-** Most words can use FW_DEFAULT.
-** nAllot - number of extra cells to allocate in the parameter area (usually zero)
-*/
-int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags);
/*
** f i c l C o m p i l e C o r e
** Builds the ANS CORE wordset into the dictionary - called by
-** ficlInitSystem - no need to waste dict space by doing it again.
-*/
-void ficlCompileCore(FICL_SYSTEM *pSys);
-void ficlCompilePrefix(FICL_SYSTEM *pSys);
-void ficlCompileSearch(FICL_SYSTEM *pSys);
-void ficlCompileSoftCore(FICL_SYSTEM *pSys);
-void ficlCompileTools(FICL_SYSTEM *pSys);
-void ficlCompileFile(FICL_SYSTEM *pSys);
+** ficlInitSystem - no need to waste dictionary space by doing it again.
+*/
+FICL_PLATFORM_EXTERN void ficlSystemCompileCore(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompilePrefix(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileSearch(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileSoftCore(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileTools(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileFile(ficlSystem *system);
#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);
+FICL_PLATFORM_EXTERN void ficlSystemCompileFloat(ficlSystem *system);
+FICL_PLATFORM_EXTERN int ficlVmParseFloatNumber(ficlVm *vm, ficlString s);
+#endif /* FICL_WANT_FLOAT */
+#if FICL_WANT_PLATFORM
+FICL_PLATFORM_EXTERN void ficlSystemCompilePlatform(ficlSystem *system);
+#endif /* FICL_WANT_PLATFORM */
+FICL_PLATFORM_EXTERN void ficlSystemCompileExtras(ficlSystem *system);
+
+
+FICL_PLATFORM_EXTERN int ficlVmParsePrefix(ficlVm *vm, ficlString s);
+
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN ficlWord *ficlSystemLookupLocal(ficlSystem *system, ficlString name);
#endif
-int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si);
/*
** from words.c...
*/
-void constantParen(FICL_VM *pVM);
-void twoConstParen(FICL_VM *pVM);
-int ficlParseNumber(FICL_VM *pVM, STRINGINFO si);
-void ficlTick(FICL_VM *pVM);
-void parseStepParen(FICL_VM *pVM);
+FICL_PLATFORM_EXTERN int ficlVmParseNumber(ficlVm *vm, ficlString s);
+FICL_PLATFORM_EXTERN void ficlPrimitiveTick(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlPrimitiveParseStepParen(ficlVm *vm);
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN void ficlLocalParen(ficlVm *vm, int isDouble, int isFloat);
+#endif /* FICL_WANT_LOCALS */
+
+
+/*
+** Appends a parse step function to the end of the parse list (see
+** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
+** nonzero if there's no more room in the list. Each parse step is a word in
+** the dictionary. Precompiled parse steps can use (PARSE-STEP) as their
+** CFA - see parenParseStep in words.c.
+*/
+FICL_PLATFORM_EXTERN int ficlSystemAddParseStep(ficlSystem *system, ficlWord *word); /* ficl.c */
+FICL_PLATFORM_EXTERN void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep pStep);
+
/*
** From tools.c
*/
-int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW);
/*
** The following supports SEE and the debugger.
*/
typedef enum
{
- BRANCH,
- COLON,
- CONSTANT,
- CREATE,
- DO,
- DOES,
- IF,
- LITERAL,
- LOOP,
- OF,
- PLOOP,
- PRIMITIVE,
- QDO,
- STRINGLIT,
- CSTRINGLIT,
+ FICL_WORDKIND_BRANCH,
+ FICL_WORDKIND_BRANCH0,
+ FICL_WORDKIND_COLON,
+ FICL_WORDKIND_CONSTANT,
+ FICL_WORDKIND_2CONSTANT,
+ FICL_WORDKIND_CREATE,
+ FICL_WORDKIND_DO,
+ FICL_WORDKIND_DOES,
+ FICL_WORDKIND_LITERAL,
+ FICL_WORDKIND_2LITERAL,
+#if FICL_WANT_FLOAT
+ FICL_WORDKIND_FLITERAL,
+#endif /* FICL_WANT_FLOAT */
+ FICL_WORDKIND_LOOP,
+ FICL_WORDKIND_OF,
+ FICL_WORDKIND_PLOOP,
+ FICL_WORDKIND_PRIMITIVE,
+ FICL_WORDKIND_QDO,
+ FICL_WORDKIND_STRING_LITERAL,
+ FICL_WORDKIND_CSTRING_LITERAL,
#if FICL_WANT_USER
- USER,
+ FICL_WORDKIND_USER,
#endif
- VARIABLE,
-} WORDKIND;
+ FICL_WORDKIND_VARIABLE,
+ FICL_WORDKIND_INSTRUCTION,
+ FICL_WORDKIND_INSTRUCTION_WORD,
+ FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT,
+} ficlWordKind;
+
+ficlWordKind ficlWordClassify(ficlWord *word);
-WORDKIND ficlWordClassify(FICL_WORD *pFW);
@@ -1104,11 +1784,76 @@ WORDKIND ficlWordClassify(FICL_WORD *pFW);
#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND))
-typedef struct ficlFILE
+typedef struct ficlFile
{
- FILE *f;
- char filename[256];
-} ficlFILE;
+ FILE *f;
+ char filename[256];
+} ficlFile;
+
+
+#if defined (FICL_PLATFORM_HAS_FTRUNCATE)
+FICL_PLATFORM_EXTERN int ficlFileTruncate(ficlFile *ff, ficlUnsigned size);
+#endif
+
+FICL_PLATFORM_EXTERN int ficlFileStatus(char *filename, int *status);
+FICL_PLATFORM_EXTERN long ficlFileSize(ficlFile *ff);
+
+
+/*
+** Used with compressed softcore.
+**
+*/
+
+#ifndef FICL_BIT_NUMBER
+#define FICL_BIT_NUMBER(x) (1 << (x))
+#endif /* FICL_BIT_NUMBER */
+
+#ifndef FICL_BIT_SET
+#define FICL_BIT_SET(value, flag) ((value) |= (flag))
+#endif /* FICL_BIT_SET */
+
+#ifndef FICL_BIT_CLEAR
+#define FICL_BIT_CLEAR(value, flag) ((value) &= ~(flag))
+#endif /* FICL_BIT_CLEAR */
+
+#ifndef FICL_BIT_CHECK
+#define FICL_BIT_CHECK(value, flag) ((value) & (flag))
+#endif /* FICL_BIT_CHECK */
+
+
+#define FICL_LZ_TYPE_BITS (1)
+#define FICL_LZ_OFFSET_BITS (12)
+#define FICL_LZ_LENGTH_BITS (5)
+#define FICL_LZ_NEXT_BITS (8)
+#define FICL_LZ_PHRASE_BITS (FICL_LZ_TYPE_BITS + FICL_LZ_OFFSET_BITS + FICL_LZ_LENGTH_BITS + FICL_LZ_NEXT_BITS)
+#define FICL_LZ_SYMBOL_BITS (FICL_LZ_TYPE_BITS + FICL_LZ_NEXT_BITS)
+
+/*
+** if you match fewer characters than this, don't bother,
+** it's smaller to encode it as a sequence of symbol tokens.
+**/
+#define FICL_LZ_MINIMUM_USEFUL_MATCH ((int)(FICL_LZ_PHRASE_BITS / FICL_LZ_SYMBOL_BITS))
+
+#define FICL_LZ_WINDOW_SIZE (FICL_BIT_NUMBER(FICL_LZ_OFFSET_BITS))
+#define FICL_LZ_BUFFER_SIZE (FICL_BIT_NUMBER(FICL_LZ_LENGTH_BITS) + FICL_LZ_MINIMUM_USEFUL_MATCH)
+
+FICL_PLATFORM_EXTERN int ficlBitGet(const unsigned char *bits, size_t index);
+FICL_PLATFORM_EXTERN void ficlBitSet(unsigned char *bits, size_t size_t, int value);
+FICL_PLATFORM_EXTERN void ficlBitGetString(unsigned char *destination, const unsigned char *source, int offset, int count, int destAlignment);
+
+FICL_PLATFORM_EXTERN ficlUnsigned16 ficlNetworkUnsigned16(ficlUnsigned16 number);
+FICL_PLATFORM_EXTERN ficlUnsigned32 ficlNetworkUnsigned32(ficlUnsigned32 number);
+
+#define FICL_MIN(a, b) (((a) < (b)) ? (a) : (b))
+FICL_PLATFORM_EXTERN int ficlLzCompress(const unsigned char *uncompressed, size_t uncompressedSize, unsigned char **compressed, size_t *compressedSize);
+FICL_PLATFORM_EXTERN int ficlLzUncompress(const unsigned char *compressed, unsigned char **uncompressed, size_t *uncompressedSize);
+
+
+
+#if FICL_WANT_COMPATIBILITY
+ #include "ficlcompatibility.h"
+#endif /* FICL_WANT_COMPATIBILITY */
+
#ifdef __cplusplus
}
diff --git a/ficlcompatibility.h b/ficlcompatibility.h
new file mode 100644
index 000000000000..0bbc69773dcf
--- /dev/null
+++ b/ficlcompatibility.h
@@ -0,0 +1,463 @@
+#ifndef FICL_FORCE_COMPATIBILITY
+
+struct ficl_word;
+typedef struct ficl_word FICL_WORD;
+struct vm;
+typedef struct vm FICL_VM;
+struct ficl_dict;
+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;
+#define ficlFILE ficlFile
+
+typedef ficlUnsigned FICL_UNS;
+typedef ficlInteger FICL_INT;
+typedef ficlFloat FICL_FLOAT;
+typedef ficlUnsigned16 UNS16;
+typedef ficlUnsigned8 UNS8;
+
+#define _cell ficlCell
+#define CELL ficlCell
+
+#define LVALUEtoCELL(v) (*(ficlCell *)&v)
+#define PTRtoCELL (ficlCell *)(void *)
+#define PTRtoSTRING (ficlCountedString *)(void *)
+
+typedef unsigned char FICL_COUNT;
+#define FICL_STRING_MAX UCHAR_MAX
+typedef struct _ficl_string
+{
+ ficlUnsigned8 count;
+ char text[1];
+} FICL_STRING;
+
+typedef struct
+{
+ ficlUnsigned count;
+ char *cp;
+} STRINGINFO;
+
+#define SI_COUNT(si) (si.count)
+#define SI_PTR(si) (si.cp)
+#define SI_SETLEN(si, len) (si.count = (FICL_UNS)(len))
+#define SI_SETPTR(si, ptr) (si.cp = (char *)(ptr))
+#define SI_PSZ(si, psz) \
+ {si.cp = psz; si.count = (FICL_COUNT)strlen(psz);}
+#define SI_PFS(si, pfs) \
+ {si.cp = pfs->text; si.count = pfs->count;}
+
+typedef struct
+{
+ ficlInteger index;
+ char *end;
+ char *cp;
+} TIB;
+
+
+typedef struct _ficlStack
+{
+ ficlUnsigned nCells; /* size of the stack */
+ CELL *pFrame; /* link reg for stack frame */
+ CELL *sp; /* stack pointer */
+ ficlVm *vm;
+ char *name;
+ CELL base[1]; /* Top of stack */
+} FICL_STACK;
+
+FICL_STACK *stackCreate (unsigned nCells);
+void stackDelete (FICL_STACK *pStack);
+int stackDepth (FICL_STACK *pStack);
+void stackDrop (FICL_STACK *pStack, int n);
+CELL stackFetch (FICL_STACK *pStack, int n);
+CELL stackGetTop (FICL_STACK *pStack);
+void stackLink (FICL_STACK *pStack, int nCells);
+void stackPick (FICL_STACK *pStack, int n);
+CELL stackPop (FICL_STACK *pStack);
+void *stackPopPtr (FICL_STACK *pStack);
+FICL_UNS stackPopUNS (FICL_STACK *pStack);
+FICL_INT stackPopINT (FICL_STACK *pStack);
+void stackPush (FICL_STACK *pStack, CELL c);
+void stackPushPtr (FICL_STACK *pStack, void *ptr);
+void stackPushUNS (FICL_STACK *pStack, FICL_UNS u);
+void stackPushINT (FICL_STACK *pStack, FICL_INT i);
+void stackReset (FICL_STACK *pStack);
+void stackRoll (FICL_STACK *pStack, int n);
+void stackSetTop (FICL_STACK *pStack, CELL c);
+void stackStore (FICL_STACK *pStack, int n, CELL c);
+void stackUnlink (FICL_STACK *pStack);
+
+#if (FICL_WANT_FLOAT)
+float stackPopFloat (FICL_STACK *pStack);
+void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f);
+#endif
+
+#define PUSHPTR(p) stackPushPtr(pVM->pStack,p)
+#define PUSHUNS(u) stackPushUNS(pVM->pStack,u)
+#define PUSHINT(i) stackPushINT(pVM->pStack,i)
+#define PUSHFLOAT(f) stackPushFloat(pVM->fStack,f)
+#define PUSH(c) stackPush(pVM->pStack,c)
+#define POPPTR() stackPopPtr(pVM->pStack)
+#define POPUNS() stackPopUNS(pVM->pStack)
+#define POPINT() stackPopINT(pVM->pStack)
+#define POPFLOAT() stackPopFloat(pVM->fStack)
+#define POP() stackPop(pVM->pStack)
+#define GETTOP() stackGetTop(pVM->pStack)
+#define SETTOP(c) stackSetTop(pVM->pStack,LVALUEtoCELL(c))
+#define GETTOPF() stackGetTop(pVM->fStack)
+#define SETTOPF(c) stackSetTop(pVM->fStack,LVALUEtoCELL(c))
+#define STORE(n,c) stackStore(pVM->pStack,n,LVALUEtoCELL(c))
+#define DEPTH() stackDepth(pVM->pStack)
+#define DROP(n) stackDrop(pVM->pStack,n)
+#define DROPF(n) stackDrop(pVM->fStack,n)
+#define FETCH(n) stackFetch(pVM->pStack,n)
+#define PICK(n) stackPick(pVM->pStack,n)
+#define PICKF(n) stackPick(pVM->fStack,n)
+#define ROLL(n) stackRoll(pVM->pStack,n)
+#define ROLLF(n) stackRoll(pVM->fStack,n)
+
+typedef FICL_WORD ** IPTYPE; /* the VM's instruction pointer */
+typedef void (*OUTFUNC)(FICL_VM *pVM, char *text, int fNewline);
+
+/* values of STATE */
+#define INTERPRET FICL_STATE_INTERPRET
+#define COMPILE FICL_STATE_COMPILE
+
+#if !defined nPAD
+#define nPAD FICL_PAD_SIZE
+#endif
+
+#if !defined nFICLNAME
+#define nFICLNAME FICL_NAME_LENGTH
+#endif
+
+#define FICL_DEFAULT_STACK FICL_DEFAULT_STACK_SIZE
+#define FICL_DEFAULT_DICT FICL_DEFAULT_DICTIONARY_SIZE
+#define FICL_DEFAULT_ENV FICL_DEFAULT_ENVIRONMENT_SIZE
+#define FICL_DEFAULT_VOCS FICL_MAX_WORDLISTS
+
+
+
+
+
+struct vm
+{
+ void *pExtend;
+ ficlOutputFunction textOut;
+ ficlOutputFunction errorOut;
+ ficlSystem *pSys;
+ ficlVm *pVM;
+ FICL_VM *link; /* Ficl keeps a VM list for simple teardown */
+ jmp_buf *pState; /* crude exception mechanism... */
+ short fRestart; /* Set TRUE to restart runningWord */
+ IPTYPE ip; /* instruction pointer */
+ FICL_WORD *runningWord;/* address of currently running word (often just *(ip-1) ) */
+ FICL_UNS state; /* compiling or interpreting */
+ FICL_UNS base; /* number conversion base */
+ FICL_STACK *pStack; /* param stack */
+ FICL_STACK *rStack; /* return stack */
+#if FICL_WANT_FLOAT
+ FICL_STACK *fStack; /* float stack (optional) */
+#endif
+ 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];
+#endif
+ char pad[nPAD]; /* the scratch area (see above) */
+};
+
+/*
+** A FICL_CODE points to a function that gets called to help execute
+** a word in the dictionary. It always gets passed a pointer to the
+** running virtual machine, and from there it can get the address
+** of the parameter area of the word it's supposed to operate on.
+** For precompiled words, the code is all there is. For user defined
+** words, the code assumes that the word's parameter area is a list
+** of pointers to the code fields of other words to execute, and
+** may also contain inline data. The first parameter is always
+** a pointer to a code field.
+*/
+typedef void (*FICL_CODE)(FICL_VM *pVm);
+
+#if 0
+#define VM_ASSERT(pVM) assert((*(pVM->ip - 1)) == pVM->runningWord)
+#else
+#define VM_ASSERT(pVM)
+#endif
+
+#define nName length
+#define ficl_word ficlWord
+#define FICL_WORD ficlWord
+
+#define CELLS_PER_WORD \
+ ( (sizeof (FICL_WORD) + nFICLNAME + sizeof (CELL)) \
+ / (sizeof (CELL)) )
+
+int wordIsImmediate(FICL_WORD *pFW);
+int wordIsCompileOnly(FICL_WORD *pFW);
+
+#define FW_IMMEDIATE FICL_WORD_IMMEDIATE
+#define FW_COMPILE FICL_WORD_COMPILE_ONLY
+#define FW_SMUDGE FICL_WORD_SMUDGED
+#define FW_ISOBJECT FICL_WORD_OBJECT
+
+#define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE_ONLY)
+#define FW_DEFAULT 0
+
+
+/*
+** Exit codes for vmThrow
+*/
+#define VM_INNEREXIT FICL_VM_STATUS_INNER_EXIT
+#define VM_OUTOFTEXT FICL_VM_STATUS_OUT_OF_TEXT
+#define VM_RESTART FICL_VM_STATUS_RESTART
+#define VM_USEREXIT FICL_VM_STATUS_USER_EXIT
+#define VM_ERREXIT FICL_VM_STATUS_ERROR_EXIT
+#define VM_BREAK FICL_VM_STATUS_BREAK
+#define VM_ABORT FICL_VM_STATUS_ABORT
+#define VM_ABORTQ FICL_VM_STATUS_ABORTQ
+#define VM_QUIT FICL_VM_STATUS_QUIT
+
+
+void vmBranchRelative(FICL_VM *pVM, int offset);
+FICL_VM * vmCreate (FICL_VM *pVM, unsigned nPStack, unsigned nRStack);
+void vmDelete (FICL_VM *pVM);
+void vmExecute (FICL_VM *pVM, FICL_WORD *pWord);
+FICL_DICT *vmGetDict (FICL_VM *pVM);
+char * vmGetString (FICL_VM *pVM, FICL_STRING *spDest, char delimiter);
+STRINGINFO vmGetWord (FICL_VM *pVM);
+STRINGINFO vmGetWord0 (FICL_VM *pVM);
+int vmGetWordToPad (FICL_VM *pVM);
+STRINGINFO vmParseString (FICL_VM *pVM, char delimiter);
+STRINGINFO vmParseStringEx(FICL_VM *pVM, char delimiter, char fSkipLeading);
+CELL vmPop (FICL_VM *pVM);
+void vmPush (FICL_VM *pVM, CELL c);
+void vmPopIP (FICL_VM *pVM);
+void vmPushIP (FICL_VM *pVM, IPTYPE newIP);
+void vmQuit (FICL_VM *pVM);
+void vmReset (FICL_VM *pVM);
+void vmSetTextOut (FICL_VM *pVM, OUTFUNC textOut);
+void vmTextOut (FICL_VM *pVM, char *text, int fNewline);
+void vmThrow (FICL_VM *pVM, int except);
+void vmThrowErr (FICL_VM *pVM, char *fmt, ...);
+
+#define vmGetRunningWord(pVM) ((pVM)->runningWord)
+
+
+#define M_VM_STEP(pVM) \
+ FICL_WORD *tempFW = *(pVM)->ip++; \
+ ficlVmInnerLoop((ficlVm *)pVM, (ficlWord *)tempFW); \
+
+#define M_INNER_LOOP(pVM) \
+ ficlVmInnerLoop((ficlVm *)pVm);
+
+
+void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
+#if FICL_WANT_FLOAT
+void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells);
+#endif
+
+void vmPushTib (FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib);
+void vmPopTib (FICL_VM *pVM, TIB *pTib);
+#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
+#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp)
+#define vmGetInBufEnd(pVM) ((pVM)->tib.end)
+#define vmGetTibIndex(pVM) (pVM)->tib.index
+#define vmSetTibIndex(pVM, i) (pVM)->tib.index = i
+#define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp
+
+#if defined(_WIN32)
+/* #SHEESH
+** Why do Microsoft Meatballs insist on contaminating
+** my namespace with their string functions???
+*/
+#pragma warning(disable: 4273)
+#endif
+
+int isPowerOfTwo(FICL_UNS u);
+
+char *ltoa( FICL_INT value, char *string, int radix );
+char *ultoa(FICL_UNS value, char *string, int radix );
+char digit_to_char(int value);
+char *strrev( char *string );
+char *skipSpace(char *cp, char *end);
+char *caseFold(char *cp);
+int strincmp(char *cp1, char *cp2, FICL_UNS count);
+
+#if defined(_WIN32)
+#pragma warning(default: 4273)
+#endif
+
+#if !defined HASHSIZE /* Default size of hash table. For most uniform */
+#define HASHSIZE FICL_HASHSIZE /* performance, use a prime number! */
+#endif
+
+#define ficl_hash ficlHash
+#define FICL_HASH ficlHash
+
+void hashForget (FICL_HASH *pHash, void *where);
+UNS16 hashHashCode (STRINGINFO si);
+void hashInsertWord(FICL_HASH *pHash, FICL_WORD *pFW);
+FICL_WORD *hashLookup (FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode);
+void hashReset (FICL_HASH *pHash);
+
+struct ficl_dict
+{
+ CELL *here;
+ void *context;
+ FICL_WORD *smudge;
+ FICL_HASH *pForthWords;
+ FICL_HASH *pCompile;
+ FICL_HASH *pSearch[FICL_DEFAULT_VOCS];
+ int nLists;
+ unsigned size; /* Number of cells in dict (total)*/
+ ficlSystem *system;
+ CELL dict[1]; /* Base of dictionary memory */
+};
+
+void *alignPtr(void *ptr);
+void dictAbortDefinition(FICL_DICT *pDict);
+void dictAlign (FICL_DICT *pDict);
+int dictAllot (FICL_DICT *pDict, int n);
+int dictAllotCells (FICL_DICT *pDict, int nCells);
+void dictAppendCell (FICL_DICT *pDict, CELL c);
+void dictAppendChar (FICL_DICT *pDict, char c);
+FICL_WORD *dictAppendWord (FICL_DICT *pDict,
+ char *name,
+ FICL_CODE pCode,
+ UNS8 flags);
+FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
+ STRINGINFO si,
+ FICL_CODE pCode,
+ UNS8 flags);
+void dictAppendUNS (FICL_DICT *pDict, FICL_UNS u);
+int dictCellsAvail (FICL_DICT *pDict);
+int dictCellsUsed (FICL_DICT *pDict);
+void dictCheck (FICL_DICT *pDict, FICL_VM *pVM, int n);
+FICL_DICT *dictCreate(unsigned nCELLS);
+FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash);
+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
+FICL_WORD *ficlLookupLoc (FICL_SYSTEM *pSys, STRINGINFO si);
+#endif
+void dictResetSearchOrder(FICL_DICT *pDict);
+void dictSetFlags (FICL_DICT *pDict, UNS8 set, UNS8 clr);
+void dictSetImmediate(FICL_DICT *pDict);
+void dictUnsmudge (FICL_DICT *pDict);
+CELL *dictWhere (FICL_DICT *pDict);
+
+typedef int (*FICL_PARSE_STEP)(FICL_VM *pVM, STRINGINFO si);
+
+int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW); /* ficl.c */
+void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep);
+void ficlListParseSteps(FICL_VM *pVM);
+
+typedef struct FICL_BREAKPOINT
+{
+ void *address;
+ FICL_WORD *origXT;
+} FICL_BREAKPOINT;
+
+
+struct ficl_system
+{
+ void *pExtend;
+ ficlOutputFunction textOut;
+ ficlOutputFunction errorTextOut;
+ ficlSystem *pSys;
+ ficlVm *vm;
+ FICL_SYSTEM *link;
+ FICL_VM *vmList;
+ FICL_DICT *dp;
+ FICL_DICT *envp;
+ FICL_WORD *pInterp[3];
+ FICL_WORD *parseList[FICL_MAX_PARSE_STEPS];
+
+ FICL_WORD *pExitInner;
+ FICL_WORD *pInterpret;
+
+#if FICL_WANT_LOCALS
+ FICL_DICT *localp;
+ FICL_INT nLocals;
+ CELL *pMarkLocals;
+#endif
+
+ ficlInteger stackSize;
+
+ FICL_BREAKPOINT bpStep;
+};
+
+struct ficl_system_info
+{
+ int size; /* structure size tag for versioning */
+ void *pExtend; /* Initializes VM's pExtend pointer - for application use */
+ int nDictCells; /* Size of system's Dictionary */
+ int stackSize; /* Size of system's Dictionary */
+ OUTFUNC textOut; /* default textOut function */
+ int nEnvCells; /* Size of Environment dictionary */
+};
+
+
+#define ficlInitInfo(x) { memset((x), 0, sizeof(FICL_SYSTEM_INFO)); \
+ (x)->size = sizeof(FICL_SYSTEM_INFO); }
+
+FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi);
+FICL_SYSTEM *ficlInitSystem(int nDictCells);
+void ficlTermSystem(FICL_SYSTEM *pSys);
+int ficlEvaluate(FICL_VM *pVM, char *pText);
+int ficlExec (FICL_VM *pVM, char *pText);
+int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT nChars);
+int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord);
+FICL_VM *ficlNewVM(FICL_SYSTEM *pSys);
+void ficlFreeVM(FICL_VM *pVM);
+int ficlSetStackSize(int nStackCells);
+FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name);
+FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys);
+FICL_DICT *ficlGetEnv (FICL_SYSTEM *pSys);
+void ficlSetEnv (FICL_SYSTEM *pSys, char *name, FICL_UNS value);
+void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo);
+#if FICL_WANT_LOCALS
+FICL_DICT *ficlGetLoc (FICL_SYSTEM *pSys);
+#endif
+int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags);
+void ficlCompileCore(FICL_SYSTEM *pSys);
+void ficlCompilePrefix(FICL_SYSTEM *pSys);
+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_WANT_PLATFORM
+void ficlCompilePlatform(FICL_SYSTEM *pSys);
+#endif
+int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si);
+
+void constantParen(FICL_VM *pVM);
+void twoConstParen(FICL_VM *pVM);
+int ficlParseNumber(FICL_VM *pVM, STRINGINFO si);
+void ficlTick(FICL_VM *pVM);
+void parseStepParen(FICL_VM *pVM);
+
+int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW);
+
+
+
+/* we define it ourselves, for naughty programs that call it directly. */
+void ficlTextOut (FICL_VM *pVM, char *text, int fNewline);
+/* but you can use this one! */
+void ficlTextOutLocal (FICL_VM *pVM, char *text, int fNewline);
+
+
+#endif /* FICL_FORCE_COMPATIBILITY */
diff --git a/ficldll.def b/ficldll.def
new file mode 100644
index 000000000000..262b4fcff365
--- /dev/null
+++ b/ficldll.def
@@ -0,0 +1,176 @@
+;;;
+;;; Generated by makedef.py at 2003/05/17 19:58:13
+;;;
+
+EXPORTS
+
+ficl2IntegerAbsoluteValue @1
+ficl2IntegerDivideFloored @2
+ficl2IntegerDivideSymmetric @3
+ficl2UnsignedDivide @4
+ficlAlignPointer @5
+ficlBitGet @6
+ficlBitGetString @7
+ficlBitSet @8
+ficlCallbackAssert @9
+ficlCallbackDefaultTextOut @10
+ficlCallbackTextOut @11
+ficlDictionaryAbortDefinition @12
+ficlDictionaryAlign @13
+ficlDictionaryAllot @14
+ficlDictionaryAllotCells @15
+ficlDictionaryAppend2Constant @16
+ficlDictionaryAppend2ConstantInstruction @17
+ficlDictionaryAppendCell @18
+ficlDictionaryAppendCharacter @19
+ficlDictionaryAppendConstant @20
+ficlDictionaryAppendConstantInstruction @21
+ficlDictionaryAppendData @22
+ficlDictionaryAppendInstruction @23
+ficlDictionaryAppendPrimitive @24
+ficlDictionaryAppendString @25
+ficlDictionaryAppendUnsigned @26
+ficlDictionaryAppendWord @27
+ficlDictionaryCellsAvailable @28
+ficlDictionaryCellsUsed @29
+ficlDictionaryClearFlags @30
+ficlDictionaryCreate @31
+ficlDictionaryCreateHashed @32
+ficlDictionaryCreateWordlist @33
+ficlDictionaryDestroy @34
+ficlDictionaryEmpty @35
+ficlDictionaryFindEnclosingWord @36
+ficlDictionaryIncludes @37
+ficlDictionaryIsAWord @38
+ficlDictionaryLookup @39
+ficlDictionaryResetSearchOrder @40
+ficlDictionarySee @41
+ficlDictionarySet2Constant @42
+ficlDictionarySet2ConstantInstruction @43
+ficlDictionarySetConstant @44
+ficlDictionarySetConstantInstruction @45
+ficlDictionarySetFlags @46
+ficlDictionarySetImmediate @47
+ficlDictionarySetInstruction @48
+ficlDictionarySetPrimitive @49
+ficlDictionaryUnsmudge @50
+ficlDictionaryWhere @51
+ficlDigitToCharacter @52
+ficlFileTruncate @53
+ficlFree @54
+ficlHashCode @55
+ficlHashForget @56
+ficlHashInsertWord @57
+ficlHashLookup @58
+ficlHashReset @59
+ficlIsPowerOfTwo @60
+ficlLocalParen @61
+ficlLocalParenIm @62
+ficlLtoa @63
+ficlLzDecodeHeaderField @64
+ficlLzUncompress @65
+ficlMalloc @66
+ficlPrimitiveHashSummary @67
+ficlPrimitiveLiteralIm @68
+ficlPrimitiveParseStepParen @69
+ficlPrimitiveTick @70
+ficlRealloc @71
+ficlStackCheck @72
+ficlStackCreate @73
+ficlStackDepth @74
+ficlStackDestroy @75
+ficlStackWalk @76
+ficlStackDisplay @77
+ficlStackDrop @78
+ficlStackFetch @79
+ficlStackGetTop @80
+ficlStackLink @81
+ficlStackPick @82
+ficlStackPop @83
+ficlStackPop2Integer @84
+ficlStackPop2Unsigned @85
+ficlStackPopFloat @86
+ficlStackPopInteger @87
+ficlStackPopPointer @88
+ficlStackPopUnsigned @89
+ficlStackPush @90
+ficlStackPush2Integer @91
+ficlStackPush2Unsigned @92
+ficlStackPushFloat @93
+ficlStackPushInteger @94
+ficlStackPushPointer @95
+ficlStackPushUnsigned @96
+ficlStackReset @97
+ficlStackRoll @98
+ficlStackSetTop @99
+ficlStackStore @100
+ficlStackUnlink @101
+ficlStrincmp @102
+ficlStringCaseFold @103
+ficlStringReverse @104
+ficlStringSkipSpace @105
+ficlSystemAddParseStep @106
+ficlSystemAddPrimitiveParseStep @107
+ficlSystemCompileCore @108
+ficlSystemCompileFile @109
+ficlSystemCompileFloat @110
+ficlSystemCompilePlatform @111
+ficlSystemCompilePrefix @112
+ficlSystemCompileSearch @113
+ficlSystemCompileSoftCore @114
+ficlSystemCompileTools @115
+ficlSystemCreate @116
+ficlSystemCreateVm @117
+ficlSystemDestroy @118
+ficlSystemDestroyVm @119
+ficlSystemGetDictionary @120
+ficlSystemGetEnvironment @121
+ficlSystemGetLocals @122
+ficlSystemLookup @123
+ficlSystemLookupLocal @124
+ficlUltoa @125
+ficlVmBranchRelative @126
+ficlVmCreate @127
+ficlVmDestroy @128
+ficlVmDictionaryAllot @129
+ficlVmDictionaryAllotCells @130
+ficlVmDictionaryCheck @131
+ficlVmDictionarySimpleCheck @132
+ficlVmDisplayDataStack @133
+ficlVmDisplayDataStackSimple @134
+ficlVmDisplayFloatStack @135
+ficlVmDisplayReturnStack @136
+ficlVmEvaluate @137
+ficlVmExecuteString @138
+ficlVmExecuteWord @139
+ficlVmExecuteXT @140
+ficlVmGetDictionary @141
+ficlVmGetString @142
+ficlVmGetWord @143
+ficlVmGetWord0 @144
+ficlVmGetWordToPad @145
+ficlVmInnerLoop @146
+ficlVmParseFloatNumber @147
+ficlVmParseNumber @148
+ficlVmParseString @149
+ficlVmParseStringEx @150
+ficlVmParseWord @151
+ficlVmParsePrefix @152
+ficlVmPop @153
+ficlVmPopIP @154
+ficlVmPopTib @155
+ficlVmPush @156
+ficlVmPushIP @157
+ficlVmPushTib @158
+ficlVmQuit @159
+ficlVmReset @160
+ficlVmSetTextOut @161
+ficlVmTextOut @162
+ficlVmThrow @163
+ficlVmThrowError @164
+ficlWordClassify @165
+ficlWordIsCompileOnly @166
+ficlWordIsImmediate @167
+
+;;; end-of-file
+
diff --git a/ficldll.dsp b/ficldll.dsp
new file mode 100644
index 000000000000..d3564036bc5e
--- /dev/null
+++ b/ficldll.dsp
@@ -0,0 +1,219 @@
+# Microsoft Developer Studio Project File - Name="ficldll" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102
+
+CFG=ficldll - Win32 Debug Multithreaded DLL
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,
+!MESSAGE use the Export Makefile command and run
+!MESSAGE
+!MESSAGE NMAKE /f "ficldll.mak".
+!MESSAGE
+!MESSAGE You can specify a configuration when running NMAKE
+!MESSAGE by defining the macro CFG on the command line. For example:
+!MESSAGE
+!MESSAGE NMAKE /f "ficldll.mak" CFG="ficldll - Win32 Debug Multithreaded DLL"
+!MESSAGE
+!MESSAGE Possible choices for configuration are:
+!MESSAGE
+!MESSAGE "ficldll - Win32 Release Singlethreaded" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "ficldll - Win32 Release Multithreaded" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "ficldll - Win32 Release Multithreaded DLL" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "ficldll - Win32 Debug Singlethreaded" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "ficldll - Win32 Debug Multithreaded" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "ficldll - Win32 Debug Multithreaded DLL" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE
+
+# Begin Project
+# PROP AllowPerConfigDependencies 0
+# PROP Scc_ProjName "ficldll"
+# PROP Scc_LocalPath "."
+CPP=cl.exe
+MTL=midl.exe
+RSC=rc.exe
+
+!IF "$(CFG)" == "ficldll - Win32 Release Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "dll/release/singlethreaded"
+# PROP BASE Intermediate_Dir "dll/release/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "dll/release/singlethreaded"
+# PROP Intermediate_Dir "dll/release/singlethreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD CPP /nologo /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386
+# ADD LINK32 lib/release/singlethreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /machine:I386 /out:"dll/release/singlethreaded/ficl.dll"
+
+!ELSEIF "$(CFG)" == "ficldll - Win32 Release Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "dll/release/multithreaded"
+# PROP BASE Intermediate_Dir "dll/release/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "dll/release/multithreaded"
+# PROP Intermediate_Dir "dll/release/multithreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD CPP /nologo /MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386
+# ADD LINK32 lib/release/multithreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /machine:I386 /out:"dll/release/multithreaded/ficl.dll"
+
+!ELSEIF "$(CFG)" == "ficldll - Win32 Release Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "dll/release/multithreaded_dll"
+# PROP BASE Intermediate_Dir "dll/release/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "dll/release/multithreaded_dll"
+# PROP Intermediate_Dir "dll/release/multithreaded_dll"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD CPP /nologo /MD /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /c
+# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386
+# ADD LINK32 lib/release/multithreaded_dll/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /machine:I386 /out:"dll/release/multithreaded_dll/ficl.dll"
+
+!ELSEIF "$(CFG)" == "ficldll - Win32 Debug Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "dll/debug/singlethreaded"
+# PROP BASE Intermediate_Dir "dll/debug/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "dll/debug/singlethreaded"
+# PROP Intermediate_Dir "dll/debug/singlethreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD CPP /nologo /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/singlethreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /debug /machine:I386 /out:"dll/debug/singlethreaded/ficl.dll" /pdbtype:sept
+
+!ELSEIF "$(CFG)" == "ficldll - Win32 Debug Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "dll/debug/multithreaded"
+# PROP BASE Intermediate_Dir "dll/debug/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "dll/debug/multithreaded"
+# PROP Intermediate_Dir "dll/debug/multithreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD CPP /nologo /MTd /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/multithreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /debug /machine:I386 /out:"dll/debug/multithreaded/ficl.dll" /pdbtype:sept
+
+!ELSEIF "$(CFG)" == "ficldll - Win32 Debug Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "dll/debug/multithreaded_dll"
+# PROP BASE Intermediate_Dir "dll/debug/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "dll/debug/multithreaded_dll"
+# PROP Intermediate_Dir "dll/debug/multithreaded_dll"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD CPP /nologo /MDd /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "FICLDLL_EXPORTS" /YX /FD /GZ /c
+# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/multithreaded_dll/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /map /debug /machine:I386 /out:"dll/debug/multithreaded_dll/ficl.dll" /pdbtype:sept
+
+!ENDIF
+
+# Begin Target
+
+# Name "ficldll - Win32 Release Singlethreaded"
+# Name "ficldll - Win32 Release Multithreaded"
+# Name "ficldll - Win32 Release Multithreaded DLL"
+# Name "ficldll - Win32 Debug Singlethreaded"
+# Name "ficldll - Win32 Debug Multithreaded"
+# Name "ficldll - Win32 Debug Multithreaded DLL"
+# Begin Group "Source Files"
+
+# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
+# Begin Source File
+
+SOURCE=.\ficldll.def
+# End Source File
+# End Group
+# Begin Group "Header Files"
+
+# PROP Default_Filter "h;hpp;hxx;hm;inl"
+# End Group
+# Begin Group "Resource Files"
+
+# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
+# End Group
+# End Target
+# End Project
diff --git a/ficlexe.dsp b/ficlexe.dsp
new file mode 100644
index 000000000000..5160fc6f304e
--- /dev/null
+++ b/ficlexe.dsp
@@ -0,0 +1,206 @@
+# Microsoft Developer Studio Project File - Name="ficlexe" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) Console Application" 0x0103
+
+CFG=ficlexe - Win32 Debug Multithreaded DLL
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,
+!MESSAGE use the Export Makefile command and run
+!MESSAGE
+!MESSAGE NMAKE /f "ficlexe.mak".
+!MESSAGE
+!MESSAGE You can specify a configuration when running NMAKE
+!MESSAGE by defining the macro CFG on the command line. For example:
+!MESSAGE
+!MESSAGE NMAKE /f "ficlexe.mak" CFG="ficlexe - Win32 Debug Multithreaded DLL"
+!MESSAGE
+!MESSAGE Possible choices for configuration are:
+!MESSAGE
+!MESSAGE "ficlexe - Win32 Release Singlethreaded" (based on "Win32 (x86) Console Application")
+!MESSAGE "ficlexe - Win32 Release Multithreaded" (based on "Win32 (x86) Console Application")
+!MESSAGE "ficlexe - Win32 Release Multithreaded DLL" (based on "Win32 (x86) Console Application")
+!MESSAGE "ficlexe - Win32 Debug Singlethreaded" (based on "Win32 (x86) Console Application")
+!MESSAGE "ficlexe - Win32 Debug Multithreaded" (based on "Win32 (x86) Console Application")
+!MESSAGE "ficlexe - Win32 Debug Multithreaded DLL" (based on "Win32 (x86) Console Application")
+!MESSAGE
+
+# Begin Project
+# PROP AllowPerConfigDependencies 0
+# PROP Scc_ProjName "ficlexe"
+# PROP Scc_LocalPath "."
+CPP=cl.exe
+RSC=rc.exe
+
+!IF "$(CFG)" == "ficlexe - Win32 Release Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "exe/release/singlethreaded"
+# PROP BASE Intermediate_Dir "exe/release/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "exe/release/singlethreaded"
+# PROP Intermediate_Dir "exe/release/singlethreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD CPP /nologo /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386
+# ADD LINK32 lib/release/singlethreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /machine:I386 /out:"exe/release/singlethreaded/ficl.exe"
+
+!ELSEIF "$(CFG)" == "ficlexe - Win32 Release Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "exe/release/multithreaded"
+# PROP BASE Intermediate_Dir "exe/release/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "exe/release/multithreaded"
+# PROP Intermediate_Dir "exe/release/multithreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD CPP /nologo /MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386
+# ADD LINK32 lib/release/multithreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /machine:I386 /out:"exe/release/multithreaded/ficl.exe"
+
+!ELSEIF "$(CFG)" == "ficlexe - Win32 Release Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "exe/release/multithreaded_dll"
+# PROP BASE Intermediate_Dir "exe/release/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "exe/release/multithreaded_dll"
+# PROP Intermediate_Dir "exe/release/multithreaded_dll"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD CPP /nologo /MD /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386
+# ADD LINK32 lib/release/multithreaded_dll/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /machine:I386 /out:"exe/release/multithreaded_dll/ficl.exe"
+
+!ELSEIF "$(CFG)" == "ficlexe - Win32 Debug Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "exe/debug/singlethreaded"
+# PROP BASE Intermediate_Dir "exe/debug/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "exe/debug/singlethreaded"
+# PROP Intermediate_Dir "exe/debug/singlethreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD CPP /nologo /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/singlethreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /debug /machine:I386 /out:"exe/debug/singlethreaded/ficl.exe" /pdbtype:sept
+
+!ELSEIF "$(CFG)" == "ficlexe - Win32 Debug Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "exe/debug/multithreaded"
+# PROP BASE Intermediate_Dir "exe/debug/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "exe/debug/multithreaded"
+# PROP Intermediate_Dir "exe/debug/multithreaded"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD CPP /nologo /MTd /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/multithreaded/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /debug /machine:I386 /out:"exe/debug/multithreaded/ficl.exe" /pdbtype:sept
+
+!ELSEIF "$(CFG)" == "ficlexe - Win32 Debug Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "exe/debug/multithreaded_dll"
+# PROP BASE Intermediate_Dir "exe/debug/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "exe/debug/multithreaded_dll"
+# PROP Intermediate_Dir "exe/debug/multithreaded_dll"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD CPP /nologo /MDd /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LINK32=link.exe
+# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
+# ADD LINK32 lib/debug/multithreaded_dll/ficl.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /map /debug /machine:I386 /out:"exe/debug/multithreaded_dll/ficl.exe" /pdbtype:sept
+
+!ENDIF
+
+# Begin Target
+
+# Name "ficlexe - Win32 Release Singlethreaded"
+# Name "ficlexe - Win32 Release Multithreaded"
+# Name "ficlexe - Win32 Release Multithreaded DLL"
+# Name "ficlexe - Win32 Debug Singlethreaded"
+# Name "ficlexe - Win32 Debug Multithreaded"
+# Name "ficlexe - Win32 Debug Multithreaded DLL"
+# Begin Group "Source Files"
+
+# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
+# Begin Source File
+
+SOURCE=.\main.c
+# End Source File
+# End Group
+# Begin Group "Header Files"
+
+# PROP Default_Filter "h;hpp;hxx;hm;inl"
+# End Group
+# Begin Group "Resource Files"
+
+# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
+# End Group
+# End Target
+# End Project
diff --git a/ficllib.dsp b/ficllib.dsp
new file mode 100644
index 000000000000..b3f9d489eaa2
--- /dev/null
+++ b/ficllib.dsp
@@ -0,0 +1,296 @@
+# Microsoft Developer Studio Project File - Name="ficllib" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) Static Library" 0x0104
+
+CFG=ficllib - Win32 Debug Multithreaded DLL
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,
+!MESSAGE use the Export Makefile command and run
+!MESSAGE
+!MESSAGE NMAKE /f "ficllib.mak".
+!MESSAGE
+!MESSAGE You can specify a configuration when running NMAKE
+!MESSAGE by defining the macro CFG on the command line. For example:
+!MESSAGE
+!MESSAGE NMAKE /f "ficllib.mak" CFG="ficllib - Win32 Debug Multithreaded DLL"
+!MESSAGE
+!MESSAGE Possible choices for configuration are:
+!MESSAGE
+!MESSAGE "ficllib - Win32 Debug Singlethreaded" (based on "Win32 (x86) Static Library")
+!MESSAGE "ficllib - Win32 Debug Multithreaded" (based on "Win32 (x86) Static Library")
+!MESSAGE "ficllib - Win32 Debug Multithreaded DLL" (based on "Win32 (x86) Static Library")
+!MESSAGE "ficllib - Win32 Release Singlethreaded" (based on "Win32 (x86) Static Library")
+!MESSAGE "ficllib - Win32 Release Multithreaded" (based on "Win32 (x86) Static Library")
+!MESSAGE "ficllib - Win32 Release Multithreaded DLL" (based on "Win32 (x86) Static Library")
+!MESSAGE
+
+# Begin Project
+# PROP AllowPerConfigDependencies 0
+# PROP Scc_ProjName "ficllib"
+# PROP Scc_LocalPath "."
+CPP=cl.exe
+RSC=rc.exe
+
+!IF "$(CFG)" == "ficllib - Win32 Debug Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "lib/debug/singlethreaded"
+# PROP BASE Intermediate_Dir "lib/debug/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "lib/debug/singlethreaded"
+# PROP Intermediate_Dir "lib/debug/singlethreaded"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c
+# ADD CPP /nologo /W4 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/debug/singlethreaded/ficl.lib"
+
+!ELSEIF "$(CFG)" == "ficllib - Win32 Debug Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "lib/debug/multithreaded"
+# PROP BASE Intermediate_Dir "lib/debug/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "lib/debug/multithreaded"
+# PROP Intermediate_Dir "lib/debug/multithreaded"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c
+# ADD CPP /nologo /MTd /W4 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/debug/multithreaded/ficl.lib"
+
+!ELSEIF "$(CFG)" == "ficllib - Win32 Debug Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "lib/debug/multithreaded_dll"
+# PROP BASE Intermediate_Dir "lib/debug/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "lib/debug/multithreaded_dll"
+# PROP Intermediate_Dir "lib/debug/multithreaded_dll"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c
+# ADD CPP /nologo /MDd /W4 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "_DEBUG"
+# ADD RSC /l 0x409 /d "_DEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/debug/multithreaded_dll/ficl.lib"
+
+!ELSEIF "$(CFG)" == "ficllib - Win32 Release Singlethreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "lib/release/singlethreaded"
+# PROP BASE Intermediate_Dir "lib/release/singlethreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "lib/release/singlethreaded"
+# PROP Intermediate_Dir "lib/release/singlethreaded"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
+# ADD CPP /nologo /W4 /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /D FICL_ROBUST=0 /YX /FD /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/release/singlethreaded/ficl.lib"
+
+!ELSEIF "$(CFG)" == "ficllib - Win32 Release Multithreaded"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "lib/release/multithreaded"
+# PROP BASE Intermediate_Dir "lib/release/multithreaded"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "lib/release/multithreaded"
+# PROP Intermediate_Dir "lib/release/multithreaded"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
+# ADD CPP /nologo /MT /W4 /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /D FICL_ROBUST=0 /YX /FD /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/release/multithreaded/ficl.lib"
+
+!ELSEIF "$(CFG)" == "ficllib - Win32 Release Multithreaded DLL"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "lib/release/multithreaded_dll"
+# PROP BASE Intermediate_Dir "lib/release/multithreaded_dll"
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "lib/release/multithreaded_dll"
+# PROP Intermediate_Dir "lib/release/multithreaded_dll"
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
+# ADD CPP /nologo /MD /W4 /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /D FICL_ROBUST=0 /YX /FD /Zm200 /c
+# ADD BASE RSC /l 0x409 /d "NDEBUG"
+# ADD RSC /l 0x409 /d "NDEBUG"
+BSC32=bscmake.exe
+# ADD BASE BSC32 /nologo
+# ADD BSC32 /nologo
+LIB32=link.exe -lib
+# ADD BASE LIB32 /nologo
+# ADD LIB32 /nologo /out:"lib/release/multithreaded_dll/ficl.lib"
+
+!ENDIF
+
+# Begin Target
+
+# Name "ficllib - Win32 Debug Singlethreaded"
+# Name "ficllib - Win32 Debug Multithreaded"
+# Name "ficllib - Win32 Debug Multithreaded DLL"
+# Name "ficllib - Win32 Release Singlethreaded"
+# Name "ficllib - Win32 Release Multithreaded"
+# Name "ficllib - Win32 Release Multithreaded DLL"
+# Begin Group "Source Files"
+
+# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
+# Begin Source File
+
+SOURCE=.\bit.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\callback.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\compatibility.c
+# End Source File
+# Begin Source File
+
+SOURCE=dictionary.c
+# End Source File
+# Begin Source File
+
+SOURCE=double.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\extras.c
+# End Source File
+# Begin Source File
+
+SOURCE=fileaccess.c
+# End Source File
+# Begin Source File
+
+SOURCE=float.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\hash.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\lzuncompress.c
+# End Source File
+# Begin Source File
+
+SOURCE=prefix.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\primitives.c
+# End Source File
+# Begin Source File
+
+SOURCE=search.c
+# End Source File
+# Begin Source File
+
+SOURCE=softcore.c
+# End Source File
+# Begin Source File
+
+SOURCE=stack.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\system.c
+# End Source File
+# Begin Source File
+
+SOURCE=tools.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\utility.c
+# End Source File
+# Begin Source File
+
+SOURCE=vm.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficlplatform\win32.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\word.c
+# End Source File
+# End Group
+# Begin Group "Header Files"
+
+# PROP Default_Filter "h;hpp;hxx;hm;inl"
+# Begin Source File
+
+SOURCE=ficl.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficlcompatibility.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficllocal.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficltokens.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\ficlplatform\win32.h
+# End Source File
+# End Group
+# End Target
+# End Project
diff --git a/ficllocal.h b/ficllocal.h
new file mode 100644
index 000000000000..775ead6acf5b
--- /dev/null
+++ b/ficllocal.h
@@ -0,0 +1,8 @@
+/*
+** ficllocal.h
+**
+** Put all local settings here. This file will always ship empty.
+**
+*/
+
+
diff --git a/ficlplatform/alpha.h b/ficlplatform/alpha.h
new file mode 100644
index 000000000000..94aef96e3c54
--- /dev/null
+++ b/ficlplatform/alpha.h
@@ -0,0 +1,27 @@
+/*
+** FreeBSD Alpha (64 bit) data types
+*/
+
+#define FICL_WANT_PLATFORM (1)
+
+#define FICL_PLATFORM_BASIC_TYPES (1)
+#define FICL_PLATFORM_ALIGNMENT (8)
+
+#define FICL_PLATFORM_HAS_2INTEGER (0)
+#define FICL_PLATFORM_HAS_FTRUNCATE (1)
+#define FICL_PLATFORM_INLINE inline
+#define FICL_PLATFORM_OS "FreeBSD"
+#define FICL_PLATFORM_ARCHITECTURE "alpha"
+
+typedef char ficlInteger8;
+typedef unsigned char ficlUnsigned8;
+typedef short ficlInteger16;
+typedef unsigned short ficlUnsigned16;
+typedef int ficlInteger32;
+typedef unsigned int ficlUnsigned32;
+typedef long ficlInteger64;
+typedef unsigned long ficlUnsigned64;
+
+typedef ficlInteger64 ficlInteger;
+typedef ficlUnsigned64 ficlUnsigned;
+typedef float ficlFloat;
diff --git a/ficlplatform/ansi.c b/ficlplatform/ansi.c
new file mode 100644
index 000000000000..d6f285d9b3fd
--- /dev/null
+++ b/ficlplatform/ansi.c
@@ -0,0 +1,64 @@
+#include "ficl.h"
+
+
+
+
+void *ficlMalloc(size_t size)
+{
+ return malloc(size);
+}
+
+void *ficlRealloc(void *p, size_t size)
+{
+ return realloc(p, size);
+}
+
+void ficlFree(void *p)
+{
+ free(p);
+}
+
+void ficlCallbackDefaultTextOut(ficlCallback *callback, char *message)
+{
+ FICL_IGNORE(callback);
+ if (message != NULL)
+ fputs(message, stdout);
+ else
+ fflush(stdout);
+ return;
+}
+
+
+/* not supported under strict ANSI C */
+int ficlFileStatus(char *filename, int *status)
+{
+ *status = -1;
+ return -1;
+}
+
+
+/* gotta do it the hard way under strict ANSI C */
+long ficlFileSize(ficlFile *ff)
+{
+ long currentOffset;
+ long size;
+
+ if (ff == NULL)
+ return -1;
+
+ currentOffset = ftell(ff->f);
+ fseek(ff->f, 0, SEEK_END);
+ size = ftell(ff->f);
+ fseek(ff->f, currentOffset, SEEK_SET);
+
+ return size;
+}
+
+
+
+void ficlSystemCompilePlatform(ficlSystem *system)
+{
+ return;
+}
+
+
diff --git a/ficlplatform/ansi.h b/ficlplatform/ansi.h
new file mode 100644
index 000000000000..e44031066be6
--- /dev/null
+++ b/ficlplatform/ansi.h
@@ -0,0 +1,19 @@
+#include <stdint.h>
+
+typedef int8_t ficlInteger8;
+typedef uint8_t ficlUnsigned8;
+typedef int16_t ficlInteger16;
+typedef uint16_t ficlUnsigned16;
+typedef int32_t ficlInteger32;
+typedef uint32_t ficlUnsigned32;
+
+typedef intptr_t ficlInteger;
+typedef uintptr_t ficlUnsigned;
+typedef float ficlFloat;
+
+#define FICL_PLATFORM_BASIC_TYPES (1)
+#define FICL_PLATFORM_HAS_2INTEGER (0)
+#define FICL_PLATFORM_HAS_FTRUNCATE (0)
+
+#define FICL_PLATFORM_OS "ansi"
+#define FICL_PLATFORM_ARCHITECTURE "unknown"
diff --git a/ficlplatform/ficlexports.txt b/ficlplatform/ficlexports.txt
new file mode 100644
index 000000000000..65e8116869c1
--- /dev/null
+++ b/ficlplatform/ficlexports.txt
@@ -0,0 +1,168 @@
+ficl2IntegerAbsoluteValue
+ficl2IntegerDivideFloored
+ficl2IntegerDivideSymmetric
+ficl2UnsignedDivide
+ficlAlignPointer
+ficlBitGet
+ficlBitGetString
+ficlBitSet
+ficlCallbackAssert
+ficlCallbackDefaultTextOut
+ficlCallbackTextOut
+ficlDictionaryAbortDefinition
+ficlDictionaryAlign
+ficlDictionaryAllot
+ficlDictionaryAllotCells
+ficlDictionaryAppend2Constant
+ficlDictionaryAppend2ConstantInstruction
+ficlDictionaryAppendCell
+ficlDictionaryAppendCharacter
+ficlDictionaryAppendConstant
+ficlDictionaryAppendConstantInstruction
+ficlDictionaryAppendData
+ficlDictionaryAppendInstruction
+ficlDictionaryAppendPrimitive
+ficlDictionaryAppendString
+ficlDictionaryAppendUnsigned
+ficlDictionaryAppendWord
+ficlDictionaryCellsAvailable
+ficlDictionaryCellsUsed
+ficlDictionaryClearFlags
+ficlDictionaryCreate
+ficlDictionaryCreateHashed
+ficlDictionaryCreateWordlist
+ficlDictionaryDestroy
+ficlDictionaryEmpty
+ficlDictionaryFindEnclosingWord
+ficlDictionaryIncludes
+ficlDictionaryIsAWord
+ficlDictionaryLookup
+ficlDictionaryResetSearchOrder
+ficlDictionarySee
+ficlDictionarySet2Constant
+ficlDictionarySet2ConstantInstruction
+ficlDictionarySetConstant
+ficlDictionarySetConstantInstruction
+ficlDictionarySetFlags
+ficlDictionarySetImmediate
+ficlDictionarySetInstruction
+ficlDictionarySetPrimitive
+ficlDictionaryUnsmudge
+ficlDictionaryWhere
+ficlDigitToCharacter
+ficlFileTruncate
+ficlFree
+ficlHashCode
+ficlHashForget
+ficlHashInsertWord
+ficlHashLookup
+ficlHashReset
+ficlIsPowerOfTwo
+ficlLocalParen
+ficlLocalParenIm
+ficlLtoa
+ficlLzDecodeHeaderField
+ficlLzUncompress
+ficlMalloc
+ficlPrimitiveHashSummary
+ficlPrimitiveLiteralIm
+ficlPrimitiveParseStepParen
+ficlPrimitiveTick
+ficlRealloc
+ficlStackCheck
+ficlStackCreate
+ficlStackDepth
+ficlStackDestroy
+ficlStackWalk
+ficlStackDisplay
+ficlStackDrop
+ficlStackFetch
+ficlStackGetTop
+ficlStackLink
+ficlStackPick
+ficlStackPop
+ficlStackPop2Integer
+ficlStackPop2Unsigned
+ficlStackPopFloat
+ficlStackPopInteger
+ficlStackPopPointer
+ficlStackPopUnsigned
+ficlStackPush
+ficlStackPush2Integer
+ficlStackPush2Unsigned
+ficlStackPushFloat
+ficlStackPushInteger
+ficlStackPushPointer
+ficlStackPushUnsigned
+ficlStackReset
+ficlStackRoll
+ficlStackSetTop
+ficlStackStore
+ficlStackUnlink
+ficlStrincmp
+ficlStringCaseFold
+ficlStringReverse
+ficlStringSkipSpace
+ficlSystemAddParseStep
+ficlSystemAddPrimitiveParseStep
+ficlSystemCompileCore
+ficlSystemCompileFile
+ficlSystemCompileFloat
+ficlSystemCompilePlatform
+ficlSystemCompilePrefix
+ficlSystemCompileSearch
+ficlSystemCompileSoftCore
+ficlSystemCompileTools
+ficlSystemCreate
+ficlSystemCreateVm
+ficlSystemDestroy
+ficlSystemDestroyVm
+ficlSystemGetDictionary
+ficlSystemGetEnvironment
+ficlSystemGetLocals
+ficlSystemLookup
+ficlSystemLookupLocal
+ficlUltoa
+ficlVmBranchRelative
+ficlVmCreate
+ficlVmDestroy
+ficlVmDictionaryAllot
+ficlVmDictionaryAllotCells
+ficlVmDictionaryCheck
+ficlVmDictionarySimpleCheck
+ficlVmDisplayDataStack
+ficlVmDisplayDataStackSimple
+ficlVmDisplayFloatStack
+ficlVmDisplayReturnStack
+ficlVmEvaluate
+ficlVmExecuteString
+ficlVmExecuteWord
+ficlVmExecuteXT
+ficlVmGetDictionary
+ficlVmGetString
+ficlVmGetWord
+ficlVmGetWord0
+ficlVmGetWordToPad
+ficlVmInnerLoop
+ficlVmParseFloatNumber
+ficlVmParseNumber
+ficlVmParseString
+ficlVmParseStringEx
+ficlVmParseWord
+ficlVmParsePrefix
+ficlVmPop
+ficlVmPopIP
+ficlVmPopTib
+ficlVmPush
+ficlVmPushIP
+ficlVmPushTib
+ficlVmQuit
+ficlVmReset
+ficlVmSetTextOut
+ficlVmTextOut
+ficlVmThrow
+ficlVmThrowError
+ficlWordClassify
+ficlWordIsCompileOnly
+ficlWordIsImmediate
+
diff --git a/ficlplatform/makedef.py b/ficlplatform/makedef.py
new file mode 100644
index 000000000000..bea32f6093ad
--- /dev/null
+++ b/ficlplatform/makedef.py
@@ -0,0 +1,33 @@
+###
+### makedef.py
+### Generates a simple .DEF file for Ficl,
+### based on a text file containing all exported symbols.
+###
+### Contributed by Larry Hastings.
+###
+
+import string
+import time
+
+f = open("ficlexports.txt", "rt")
+output = open("../ficldll.def", "wt")
+counter = 1
+
+print >> output, ";;;"
+print >> output, ";;; Generated by makedef.py at " + time.strftime("%Y/%m/%d %H:%M:%S")
+print >> output, ";;;"
+print >> output, ""
+print >> output, "EXPORTS"
+print >> output, ""
+for a in f.readlines():
+ a = string.strip(a)
+ if len(a) == 0:
+ continue
+ print >> output, a + " @" + str(counter)
+ counter += 1
+
+print >> output, ""
+print >> output, ";;; end-of-file"
+print >> output, ""
+f.close()
+output.close()
diff --git a/ficlplatform/unix.c b/ficlplatform/unix.c
new file mode 100644
index 000000000000..4da3731f87b7
--- /dev/null
+++ b/ficlplatform/unix.c
@@ -0,0 +1,75 @@
+#include <errno.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+
+#include "ficl.h"
+
+
+
+int ficlFileTruncate(ficlFile *ff, ficlUnsigned size)
+{
+ return ftruncate(fileno(ff->f), size);
+}
+
+
+
+void *ficlMalloc(size_t size)
+{
+ return malloc(size);
+}
+
+void *ficlRealloc(void *p, size_t size)
+{
+ return realloc(p, size);
+}
+
+void ficlFree(void *p)
+{
+ free(p);
+}
+
+void ficlCallbackDefaultTextOut(ficlCallback *callback, char *message)
+{
+ FICL_IGNORE(callback);
+ if (message != NULL)
+ fputs(message, stdout);
+ else
+ fflush(stdout);
+ return;
+}
+
+int ficlFileStatus(char *filename, int *status)
+{
+ struct stat statbuf;
+ if (stat(filename, &statbuf) == 0)
+ {
+ *status = statbuf.st_mode;
+ return 0;
+ }
+ *status = ENOENT;
+ return -1;
+}
+
+
+long ficlFileSize(ficlFile *ff)
+{
+ struct stat statbuf;
+ if (ff == NULL)
+ return -1;
+
+ statbuf.st_size = -1;
+ if (fstat(fileno(ff->f), &statbuf) != 0)
+ return -1;
+
+ return statbuf.st_size;
+}
+
+
+
+
+void ficlSystemCompilePlatform(ficlSystem *system)
+{
+ return;
+}
+
+
diff --git a/ficlplatform/unix.h b/ficlplatform/unix.h
new file mode 100644
index 000000000000..b91675d6589b
--- /dev/null
+++ b/ficlplatform/unix.h
@@ -0,0 +1,46 @@
+#include <stdint.h>
+#include <unistd.h>
+
+
+#define FICL_WANT_PLATFORM (1)
+
+#define FICL_PLATFORM_OS "unix"
+#define FICL_PLATFORM_ARCHITECTURE "unknown"
+
+#define FICL_PLATFORM_BASIC_TYPES (1)
+#if defined(__amd64__)
+#define FICL_PLATFORM_ALIGNMENT (8)
+#else
+#define FICL_PLATFORM_ALIGNMENT (4)
+#endif
+#define FICL_PLATFORM_INLINE inline
+
+#define FICL_PLATFORM_HAS_FTRUNCATE (1)
+#if defined(__amd64__)
+#define FICL_PLATFORM_HAS_2INTEGER (0)
+#else
+#define FICL_PLATFORM_HAS_2INTEGER (1)
+#endif
+
+typedef int8_t ficlInteger8;
+typedef uint8_t ficlUnsigned8;
+typedef int16_t ficlInteger16;
+typedef uint16_t ficlUnsigned16;
+typedef int32_t ficlInteger32;
+typedef uint32_t ficlUnsigned32;
+typedef int64_t ficlInteger64;
+typedef uint64_t ficlUnsigned64;
+
+#if defined(__amd64__)
+typedef ficlInteger64 ficlInteger;
+typedef ficlUnsigned64 ficlUnsigned;
+#else /* default */
+typedef intptr_t ficlInteger;
+typedef uintptr_t ficlUnsigned;
+#endif
+typedef float ficlFloat;
+
+#if defined(FICL_PLATFORM_HAS_2INTEGER) && FICL_PLATFORM_HAS_2INTEGER
+typedef ficlInteger64 ficl2Integer;
+typedef ficlUnsigned64 ficl2Unsigned;
+#endif
diff --git a/ficlplatform/win32.c b/ficlplatform/win32.c
new file mode 100644
index 000000000000..d019eddddb49
--- /dev/null
+++ b/ficlplatform/win32.c
@@ -0,0 +1,413 @@
+/*
+** win32.c
+** submitted to Ficl by Larry Hastings, larry@hastings.org
+**/
+
+#include <sys/stat.h>
+#include "ficl.h"
+
+
+/*
+**
+** 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 from MSVC.
+**
+** --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 ficlFileTruncate(ficlFile *ff, ficlUnsigned size)
+{
+ HANDLE hFile = (HANDLE)_osfhnd(_fileno(ff->f));
+ if (SetFilePointer(hFile, size, NULL, FILE_BEGIN) != size)
+ return 0;
+ return !SetEndOfFile(hFile);
+}
+
+
+int ficlFileStatus(char *filename, int *status)
+{
+ /*
+ ** The Windows documentation for GetFileAttributes() says it returns
+ ** INVALID_FILE_ATTRIBUTES on error. There's no such #define. The
+ ** return value for error is -1, so we'll just use that.
+ */
+ DWORD attributes = GetFileAttributes(filename);
+ if (attributes == -1)
+ {
+ *status = GetLastError();
+ return -1;
+ }
+ *status = attributes;
+ return 0;
+}
+
+
+long ficlFileSize(ficlFile *ff)
+{
+ struct stat statbuf;
+ if (ff == NULL)
+ return -1;
+
+ statbuf.st_size = -1;
+ if (fstat(fileno(ff->f), &statbuf) != 0)
+ return -1;
+
+ return statbuf.st_size;
+}
+
+
+
+
+
+void *ficlMalloc(size_t size)
+{
+ return malloc(size);
+}
+
+void *ficlRealloc(void *p, size_t size)
+{
+ return realloc(p, size);
+}
+
+void ficlFree(void *p)
+{
+ free(p);
+}
+
+void ficlCallbackDefaultTextOut(ficlCallback *callback, char *message)
+{
+ FICL_IGNORE(callback);
+ if (message != NULL)
+ fputs(message, stdout);
+ else
+ fflush(stdout);
+ return;
+}
+
+
+
+/*
+**
+** Platform-specific functions
+**
+*/
+
+
+/*
+** m u l t i c a l l
+**
+** The be-all, end-all, swiss-army-chainsaw of native function call methods in Ficl.
+**
+** Usage:
+** ( x*argumentCount [this] [vtable] argumentCount floatArgumentBitfield cstringArgumentBitfield functionAddress flags -- returnValue | )
+** Note that any/all of the arguments (x*argumentCount) and the return value can use the
+** float stack instead of the data stack.
+**
+** To call a simple native function:
+** call with flags = MULTICALL_CALLTYPE_FUNCTION
+** To call a method on an object:
+** pass in the "this" pointer just below argumentCount,
+** call with flags = MULTICALL_CALLTYPE_METHOD
+** *do not* include the "this" pointer for the purposes of argumentCount
+** To call a virtual method on an object:
+** pass in the "this" pointer just below argumentCount,
+** call with flags = MULTICALL_CALLTYPE_VIRTUAL_METHOD
+** *do not* include the "this" pointer for the purposes of argumentCount
+** the function address must be the offset into the vtable for that function
+** It doesn't matter whether the function you're calling is "stdcall" (caller pops
+** the stack) or "fastcall" (callee pops the stack); for robustness, multicall
+** always restores the original stack pointer anyway.
+**
+**
+** To handle floating-point arguments:
+** To thunk an argument from the float stack instead of the data stack, set the corresponding bit
+** in the "floatArgumentBitfield" argument. Argument zero is bit 0 (1), argument one is bit 1 (2),
+** argument 2 is is bit 2 (4), argument 3 is bit 3 (8), etc. For instance, to call this function:
+** float greasyFingers(int a, float b, int c, float d)
+** you would call
+** 4 \ argumentCount
+** 2 8 or \ floatArgumentBitfield, thunk argument 2 (2) and 4 (8)
+** 0 \ cstringArgumentBitfield, don't thunk any arguments
+** (addressOfGreasyFingers) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-FLOAT or multicall
+**
+** To handle automatic conversion of addr-u arguments to C-style strings:
+** This is much like handling float arguments. The bit set in cstringArgumentBitfield specifies
+** the *length* argument (the higher of the two arguments) for each addr-u you want converted.
+** You must count *both* arguments for the purposes of the argumentCount parameter.
+** For instance, to call the Win32 function MessageBoxA:
+**
+** 0 "Howdy there!" "Title" 0
+** 6 \ argument count is 6! flags text-addr text-u title-addr title-u hwnd
+** 0 \ floatArgumentBitfield, don't thunk any float arguments
+** 2 8 or \ cstringArgumentBitfield, thunk for title-u (argument 2, 2) and text-u (argument 4, 8)
+** (addressOfMessageBoxA) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-INTEGER or multicall
+** The strings are copied to temporary storage and appended with a zero. These strings are freed
+** before multicall returns. If you need to call functions that write to these string buffers,
+** you'll need to handle thunking those arguments yourself.
+**
+** (If you want to call a function with more than 32 parameters, and do thunking, you need to hit somebody
+** in the head with a rock. Note: this could be you!)
+**
+** Note that, big surprise, this function is really really really dependent
+** on predefined behavior of Win32 and MSVC. It would be non-zero amounts of
+** work to port to Win64, Linux, other compilers, etc.
+**
+** --lch
+*/
+static void ficlPrimitiveMulticall(ficlVm *vm)
+{
+ int flags;
+ int functionAddress;
+ int argumentCount;
+ int *thisPointer;
+ int integerReturnValue;
+#if FICL_WANT_FLOAT
+ float floatReturnValue;
+#endif /* FICL_WANT_FLOAT */
+ int cstringArguments;
+ int floatArguments;
+ int i;
+ char **fixups;
+ int fixupCount;
+ int fixupIndex;
+ int *argumentPointer;
+ int finalArgumentCount;
+ int argumentDirection;
+ int *adjustedArgumentPointer;
+ int originalESP;
+ int vtable;
+
+ flags = ficlStackPopInteger(vm->dataStack);
+
+ functionAddress = ficlStackPopInteger(vm->dataStack);
+ if (FICL_MULTICALL_GET_CALLTYPE(flags) == FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD)
+ functionAddress *= 4;
+
+ cstringArguments = ficlStackPopInteger(vm->dataStack);
+ floatArguments = ficlStackPopInteger(vm->dataStack);
+#if !FICL_WANT_FLOAT
+ FICL_VM_ASSERT(vm, !floatArguments);
+ FICL_VM_ASSERT(vm, FICL_MULTICALL_GET_RETURNTYPE(flags) != FICL_MULTICALL_RETURNTYPE_FLOAT);
+#endif /* !FICL_WANT_FLOAT */
+ argumentCount = ficlStackPopInteger(vm->dataStack);
+
+ fixupCount = 0;
+ if (cstringArguments)
+ {
+ for (i = 0; i < argumentCount; i++)
+ if (cstringArguments & (1 << i))
+ fixupCount++;
+ fixups = (char **)malloc(fixupCount * sizeof(char *));
+ }
+ else
+ {
+ fixups = NULL;
+ }
+
+
+ /* argumentCount does *not* include the *this* pointer! */
+ if (FICL_MULTICALL_GET_CALLTYPE(flags) != FICL_MULTICALL_CALLTYPE_FUNCTION)
+ {
+ if (flags & FICL_MULTICALL_EXPLICIT_VTABLE)
+ vtable = ficlStackPopInteger(vm->dataStack);
+
+ __asm push ecx
+ thisPointer = (int *)ficlStackPopPointer(vm->dataStack);
+
+ if ((flags & FICL_MULTICALL_EXPLICIT_VTABLE) == 0)
+ vtable = *thisPointer;
+ }
+
+
+ __asm mov originalESP, esp
+
+ fixupIndex = 0;
+ finalArgumentCount = argumentCount - fixupCount;
+ __asm mov argumentPointer, esp
+ adjustedArgumentPointer = argumentPointer - finalArgumentCount;
+ __asm mov esp, adjustedArgumentPointer
+ if (flags & FICL_MULTICALL_REVERSE_ARGUMENTS)
+ {
+ argumentDirection = -1;
+ argumentPointer--;
+ }
+ else
+ {
+ argumentPointer = adjustedArgumentPointer;
+ argumentDirection = 1;
+ }
+
+ for (i = 0; i < argumentCount; i++)
+ {
+ int argument;
+
+ /* a single argument can't be both a float and a cstring! */
+ FICL_VM_ASSERT(vm, !((floatArguments & 1) && (cstringArguments & 1)));
+
+#if FICL_WANT_FLOAT
+ if (floatArguments & 1)
+ argument = ficlStackPopInteger(vm->floatStack);
+ else
+#endif /* FICL_WANT_FLOAT */
+ argument = ficlStackPopInteger(vm->dataStack);
+
+ if (cstringArguments & 1)
+ {
+ int length;
+ char *address;
+ char *buffer;
+ address = ficlStackPopPointer(vm->dataStack);
+ length = argument;
+ buffer = malloc(length + 1);
+ memcpy(buffer, address, length);
+ buffer[length] = 0;
+ fixups[fixupIndex++] = buffer;
+ argument = (int)buffer;
+ argumentCount--;
+ floatArguments >>= 1;
+ cstringArguments >>= 1;
+ }
+
+ *argumentPointer = argument;
+ argumentPointer += argumentDirection;
+
+ floatArguments >>= 1;
+ cstringArguments >>= 1;
+ }
+
+
+ /*
+ ** note! leave the "mov ecx, thisPointer" code where it is.
+ ** yes, it's duplicated in two spots.
+ ** however, MSVC likes to use ecx as a scratch variable,
+ ** so we want to set it as close as possible before the call.
+ */
+ if (FICL_MULTICALL_GET_CALLTYPE(flags) == FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD)
+ {
+ __asm
+ {
+ /* push thisPointer */
+ mov ecx, thisPointer
+ /* put vtable into eax. */
+ mov eax, vtable
+ /* pull out the address of the function we want... */
+ add eax, functionAddress
+ /* and call it. */
+ call [eax]
+ }
+ }
+ else
+ {
+ FICL_VM_ASSERT(vm, functionAddress != 0);
+ if (FICL_MULTICALL_GET_CALLTYPE(flags))
+ {
+ __asm mov ecx, thisPointer
+ }
+ __asm call functionAddress
+ }
+
+ /* save off the return value, if there is one */
+ __asm mov integerReturnValue, eax
+#if FICL_WANT_FLOAT
+ __asm fst floatReturnValue
+#endif /* FICL_WANT_FLOAT */
+
+ __asm mov esp, originalESP
+
+ if (FICL_MULTICALL_GET_CALLTYPE(flags))
+ {
+ __asm pop ecx
+ }
+
+ if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_INTEGER)
+ ficlStackPushInteger(vm->dataStack, integerReturnValue);
+ else if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_CSTRING)
+ {
+ char *str = (char *)(void *)integerReturnValue;
+ ficlStackPushInteger(vm->dataStack, integerReturnValue);
+ ficlStackPushInteger(vm->dataStack, strlen(str));
+ }
+#if FICL_WANT_FLOAT
+ else if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_FLOAT)
+ ficlStackPushFloat(vm->floatStack, floatReturnValue);
+#endif /* FICL_WANT_FLOAT */
+
+ if (fixups != NULL)
+ {
+ for (i = 0; i < fixupCount; i++)
+ if (fixups[i] != NULL)
+ free(fixups[i]);
+ free(fixups);
+ }
+
+ return;
+}
+
+
+
+
+/**************************************************************************
+ 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
+**************************************************************************/
+void ficlSystemCompilePlatform(ficlSystem *system)
+{
+ HMODULE hModule;
+ ficlDictionary *dictionary = system->dictionary;
+ FICL_SYSTEM_ASSERT(system, dictionary);
+
+ /*
+ ** one native function call to rule them all, one native function call to find them,
+ ** one native function call to bring them all and in the darkness bind them.
+ ** --lch (with apologies to j.r.r.t.)
+ */
+ ficlDictionarySetPrimitive(dictionary, "multicall", ficlPrimitiveMulticall, FICL_WORD_DEFAULT);
+ ficlDictionarySetConstant(dictionary, "multicall-calltype-function", FICL_MULTICALL_CALLTYPE_FUNCTION);
+ ficlDictionarySetConstant(dictionary, "multicall-calltype-method", FICL_MULTICALL_CALLTYPE_METHOD);
+ ficlDictionarySetConstant(dictionary, "multicall-calltype-virtual-method", FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD);
+ ficlDictionarySetConstant(dictionary, "multicall-returntype-void", FICL_MULTICALL_RETURNTYPE_VOID);
+ ficlDictionarySetConstant(dictionary, "multicall-returntype-integer", FICL_MULTICALL_RETURNTYPE_INTEGER);
+ ficlDictionarySetConstant(dictionary, "multicall-returntype-cstring", FICL_MULTICALL_RETURNTYPE_CSTRING);
+ ficlDictionarySetConstant(dictionary, "multicall-returntype-float", FICL_MULTICALL_RETURNTYPE_FLOAT);
+ ficlDictionarySetConstant(dictionary, "multicall-reverse-arguments", FICL_MULTICALL_REVERSE_ARGUMENTS);
+ ficlDictionarySetConstant(dictionary, "multicall-explit-vtable", FICL_MULTICALL_EXPLICIT_VTABLE);
+
+ /*
+ ** Every other Win32-specific word is implemented in Ficl, with multicall or whatnot.
+ ** (Give me a lever, and a place to stand, and I will move the Earth.)
+ ** See softcore/win32.fr for details. --lch
+ */
+ hModule = LoadLibrary("kernel32.dll");
+ ficlDictionarySetConstantPointer(dictionary, "kernel32.dll", hModule);
+ ficlDictionarySetConstantPointer(dictionary, "(get-proc-address)", GetProcAddress(hModule, "GetProcAddress"));
+ FreeLibrary(hModule);
+
+ return;
+}
diff --git a/ficlplatform/win32.h b/ficlplatform/win32.h
new file mode 100644
index 000000000000..c46c14df17d7
--- /dev/null
+++ b/ficlplatform/win32.h
@@ -0,0 +1,64 @@
+/*
+** Note that Microsoft's own header files won't compile without
+** "language extensions" (anonymous structs/unions) turned on.
+** And even with that, it still gives a warning in rpcasync.h:
+** warning C4115: '_RPC_ASYNC_STATE' : named type definition in parentheses
+** It compiles clean in C++. Oy vey. So I turned off the warning. --lch
+*/
+#pragma warning(disable: 4115)
+#include <windows.h>
+#pragma warning(default: 4115)
+#include <direct.h>
+
+#define FICL_WANT_PLATFORM (1)
+
+#define FICL_PLATFORM_OS "Win32"
+#define FICL_PLATFORM_ARCHITECTURE "x86"
+
+#define FICL_PLATFORM_BASIC_TYPES (1)
+#define FICL_PLATFORM_ALIGNMENT (4)
+#define FICL_PLATFORM_INLINE __inline
+
+#define FICL_PLATFORM_HAS_2INTEGER (1)
+#define FICL_PLATFORM_HAS_FTRUNCATE (1)
+
+#define fstat _fstat
+#define stat _stat
+#define getcwd _getcwd
+#define chdir _chdir
+#define fileno _fileno
+
+
+extern int ftruncate(int fileno, size_t size);
+
+typedef char ficlInteger8;
+typedef unsigned char ficlUnsigned8;
+typedef short ficlInteger16;
+typedef unsigned short ficlUnsigned16;
+typedef long ficlInteger32;
+typedef unsigned long ficlUnsigned32;
+typedef __int64 ficlInteger64;
+typedef unsigned __int64 ficlUnsigned64;
+
+typedef ficlInteger32 ficlInteger;
+typedef ficlUnsigned32 ficlUnsigned;
+typedef float ficlFloat;
+
+typedef ficlInteger64 ficl2Integer;
+typedef ficlUnsigned64 ficl2Unsigned;
+
+
+#define FICL_MULTICALL_CALLTYPE_FUNCTION (0)
+#define FICL_MULTICALL_CALLTYPE_METHOD (1)
+#define FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD (2)
+#define FICL_MULTICALL_GET_CALLTYPE(flags) ((flags) & 0x0f)
+
+#define FICL_MULTICALL_RETURNTYPE_VOID (0)
+#define FICL_MULTICALL_RETURNTYPE_INTEGER (16)
+#define FICL_MULTICALL_RETURNTYPE_CSTRING (32)
+#define FICL_MULTICALL_RETURNTYPE_FLOAT (48)
+#define FICL_MULTICALL_GET_RETURNTYPE(flags) ((flags) & 0xf0)
+
+#define FICL_MULTICALL_REVERSE_ARGUMENTS (1<<8)
+#define FICL_MULTICALL_EXPLICIT_VTABLE (1<<9) /* the vtable is specified on the stack */
+
diff --git a/ficltokens.h b/ficltokens.h
new file mode 100644
index 000000000000..b95ef0dee49e
--- /dev/null
+++ b/ficltokens.h
@@ -0,0 +1,228 @@
+FICL_TOKEN(ficlInstructionInvalid, "** invalid **")
+FICL_TOKEN(ficlInstruction1, "1")
+FICL_TOKEN(ficlInstruction2, "2")
+FICL_TOKEN(ficlInstruction3, "3")
+FICL_TOKEN(ficlInstruction4, "4")
+FICL_TOKEN(ficlInstruction5, "5")
+FICL_TOKEN(ficlInstruction6, "6")
+FICL_TOKEN(ficlInstruction7, "7")
+FICL_TOKEN(ficlInstruction8, "8")
+FICL_TOKEN(ficlInstruction9, "9")
+FICL_TOKEN(ficlInstruction10, "10")
+FICL_TOKEN(ficlInstruction11, "11")
+FICL_TOKEN(ficlInstruction12, "12")
+FICL_TOKEN(ficlInstruction13, "13")
+FICL_TOKEN(ficlInstruction14, "14")
+FICL_TOKEN(ficlInstruction15, "15")
+FICL_TOKEN(ficlInstruction16, "16")
+FICL_TOKEN(ficlInstruction0, "0")
+FICL_TOKEN(ficlInstructionNeg1, "-1")
+FICL_TOKEN(ficlInstructionNeg2, "-2")
+FICL_TOKEN(ficlInstructionNeg3, "-3")
+FICL_TOKEN(ficlInstructionNeg4, "-4")
+FICL_TOKEN(ficlInstructionNeg5, "-5")
+FICL_TOKEN(ficlInstructionNeg6, "-6")
+FICL_TOKEN(ficlInstructionNeg7, "-7")
+FICL_TOKEN(ficlInstructionNeg8, "-8")
+FICL_TOKEN(ficlInstructionNeg9, "-9")
+FICL_TOKEN(ficlInstructionNeg10, "-10")
+FICL_TOKEN(ficlInstructionNeg11, "-11")
+FICL_TOKEN(ficlInstructionNeg12, "-12")
+FICL_TOKEN(ficlInstructionNeg13, "-13")
+FICL_TOKEN(ficlInstructionNeg14, "-14")
+FICL_TOKEN(ficlInstructionNeg15, "-15")
+FICL_TOKEN(ficlInstructionNeg16, "-16")
+#if FICL_WANT_FLOAT
+FICL_TOKEN(ficlInstructionF0, "0.0e")
+FICL_TOKEN(ficlInstructionF1, "1.0e")
+FICL_TOKEN(ficlInstructionFNeg1, "-1.0e")
+#endif /* FICL_WANT_FLOAT */
+FICL_INSTRUCTION_TOKEN(ficlInstructionPlus, "+", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMinus, "-", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction1Plus, "1+", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction1Minus, "1-", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Plus, "2+", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Minus, "2-", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSemiParen, "(;)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionExitParen, "(exit)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionDup, "dup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSwap, "swap", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionGreaterThan, ">", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionBranchParenWithCheck, "(branch)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionBranchParen, "(branch-final)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionBranch0ParenWithCheck, "(branch0)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionBranch0Paren, "(branch0-final)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionLiteralParen, "(literal)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionLoopParen, "(loop)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionOfParen, "(of)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionPlusLoopParen, "(+loop)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFetch, "@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionStore, "!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionComma, ",", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCComma, "c,", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCells, "cells", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCellPlus, "cell+", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionNegate, "negate", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionStar, "*", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSlash, "/", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionStarSlash, "*/", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSlashMod, "/mod", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionStarSlashMod, "*/mod", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Star, "2*", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Slash, "2/", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionColonParen, "** (colon) **", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionVariableParen, "(variable)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionConstantParen, "(constant)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2ConstantParen, "(2constant)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2LiteralParen, "(2literal)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionDoDoes, "** do-does **", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionDoParen, "(do)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionDoesParen, "(does)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionQDoParen, "(?do)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCreateParen, "(create)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionStringLiteralParen, "(.\")", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCStringLiteralParen, "(c\")", FICL_WORD_COMPILE_ONLY)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionPlusStore, "+!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction0Less, "0<", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction0Greater, "0>", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction0Equals, "0=", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Store, "2!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Fetch, "2@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionOver, "over", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionRot, "rot", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Drop, "2drop", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Dup, "2dup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Over, "2over", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2Swap, "2swap", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFromRStack, "r>", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFetchRStack, "r@", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2ToR, "2>r", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2RFrom, "2r>", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstruction2RFetch, "2r@", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionLess, "<", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionEquals, "=", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToRStack, ">r", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionQuestionDup, "?dup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionAnd, "and", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCStore, "c!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCFetch, "c@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionDrop, "drop", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionPick, "pick", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionRoll, "roll", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMinusRoll, "-roll", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMinusRot, "-rot", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFill, "fill", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSToD, "s>d", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionULess, "u<", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionQuadFetch, "q@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionQuadStore, "q!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionWFetch, "w@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionWStore, "w!", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionInvert, "invert", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionLShift, "lshift", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMax, "max", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMin, "min", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionMove, "move", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionOr, "or", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionRShift, "rshift", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionXor, "xor", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionI, "i", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionJ, "j", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionK, "k", FICL_WORD_COMPILE_ONLY)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionCompare, "compare", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionCompareInsensitive, "compare-insensitive", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionRandom, "random", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionSeedRandom,"seed-random",FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionLeave, "leave", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionUnloop, "unloop", FICL_WORD_COMPILE_ONLY)
+
+#if FICL_WANT_USER
+FICL_INSTRUCTION_TOKEN(ficlInstructionUserParen, "(user)", FICL_WORD_DEFAULT)
+#endif /* FICL_WANT_USER */
+
+#if FICL_WANT_LOCALS
+FICL_INSTRUCTION_TOKEN(ficlInstructionLinkParen, "(link)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionUnlinkParen, "(unlink)", FICL_WORD_COMPILE_ONLY)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionGetLocalParen, "(@local)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionGet2LocalParen, "(@2Local)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToLocalParen, "(toLocal)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionTo2LocalParen, "(to2Local)", FICL_WORD_COMPILE_ONLY)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionGetLocal0, "(@local0)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionGet2Local0, "(@2Local0)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToLocal0, "(toLocal0)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionTo2Local0, "(To2Local0)", FICL_WORD_COMPILE_ONLY)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionGetLocal1, "(@local1)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToLocal1, "(toLocal1)", FICL_WORD_COMPILE_ONLY)
+
+#if FICL_WANT_FLOAT
+FICL_INSTRUCTION_TOKEN(ficlInstructionGetFLocalParen, "(@fLocal)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionGetF2LocalParen, "(@f2Local)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToFLocalParen, "(toFLocal)", FICL_WORD_COMPILE_ONLY)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToF2LocalParen, "(toF2Local)", FICL_WORD_COMPILE_ONLY)
+#endif /* FICL_WANT_FLOAT */
+
+#endif /* FICL_WANT_LOCALS */
+
+#if FICL_WANT_FLOAT
+FICL_INSTRUCTION_TOKEN(ficlInstructionFLiteralParen, "(fliteral)", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFConstantParen, "(fconstant)", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2ConstantParen, "(f2constant)", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionFPlus, "f+", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFMinus, "f-", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFStar, "f*", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFSlash, "f/", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFNegate, "fnegate", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFPlusI, "f+i", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFMinusI, "f-i", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFStarI, "f*i", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFSlashI, "f/i", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionIMinusF, "i-f", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionISlashF, "i/f", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionFFrom, "float>", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionToF, ">float", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionIntToFloat, "int>float", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFloatToInt, "float>int", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionFFetch, "f@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFStore, "f!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Fetch, "f2@", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Store, "f2!", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFPlusStore, "f+!", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionFDrop, "fdrop", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Drop, "f2drop", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFDup, "fdup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Dup, "f2dup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFMinusRoll, "f-roll", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFMinusRot, "f-rot", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFQuestionDup, "f?dup", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFOver, "fover", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Over, "f2over", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFPick, "fpick", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFRoll, "froll", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFRot, "frot", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFSwap, "fswap", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF2Swap, "f2swap", FICL_WORD_DEFAULT)
+
+FICL_INSTRUCTION_TOKEN(ficlInstructionF0Less, "f0<", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFLess, "f<", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF0Equals, "f0=", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFEquals, "f=", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionF0Greater, "f0>", FICL_WORD_DEFAULT)
+FICL_INSTRUCTION_TOKEN(ficlInstructionFGreater, "f>", FICL_WORD_DEFAULT)
+
+#endif /* FICL_WANT_FLOAT */
+
+FICL_TOKEN(ficlInstructionExitInnerLoop, "** exit inner loop **")
diff --git a/fileaccess.c b/fileaccess.c
index 98cf986ed1c1..a10f38b75339 100644
--- a/fileaccess.c
+++ b/fileaccess.c
@@ -3,7 +3,6 @@
#include <stdio.h>
#include <string.h>
#include <ctype.h>
-#include <sys/stat.h>
#include "ficl.h"
#if FICL_WANT_FILE
@@ -15,27 +14,26 @@
**
*/
-static void pushIor(FICL_VM *pVM, int success)
+static void pushIor(ficlVm *vm, int success)
{
int ior;
if (success)
ior = 0;
else
ior = errno;
- stackPushINT(pVM->pStack, ior);
+ ficlStackPushInteger(vm->dataStack, ior);
}
-static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
+static void ficlFileOpen(ficlVm *vm, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
{
- int fam = stackPopINT(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
+ int fam = ficlStackPopInteger(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
char mode[4];
FILE *f;
-
- char *filename = (char *)alloca(length + 1);
+ char *filename = (char *)malloc(length + 1);
memcpy(filename, address, length);
filename[length] = 0;
@@ -44,9 +42,9 @@ static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid
switch (FICL_FAM_OPEN_MODE(fam))
{
case 0:
- stackPushPtr(pVM->pStack, NULL);
- stackPushINT(pVM->pStack, EINVAL);
- return;
+ ficlStackPushPointer(vm->dataStack, NULL);
+ ficlStackPushInteger(vm->dataStack, EINVAL);
+ goto EXIT;
case FICL_FAM_READ:
strcat(mode, "r");
break;
@@ -63,242 +61,201 @@ static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid
f = fopen(filename, mode);
if (f == NULL)
- stackPushPtr(pVM->pStack, NULL);
+ ficlStackPushPointer(vm->dataStack, NULL);
else
{
- ficlFILE *ff = (ficlFILE *)malloc(sizeof(ficlFILE));
+ ficlFile *ff = (ficlFile *)malloc(sizeof(ficlFile));
strcpy(ff->filename, filename);
ff->f = f;
- stackPushPtr(pVM->pStack, ff);
+ ficlStackPushPointer(vm->dataStack, ff);
fseek(f, 0, SEEK_SET);
}
- pushIor(pVM, f != NULL);
+ pushIor(vm, f != NULL);
+
+EXIT:
+ free(filename);
}
-static void ficlOpenFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+static void ficlPrimitiveOpenFile(ficlVm *vm) /* ( c-addr u fam -- fileid ior ) */
{
- ficlFopen(pVM, "a");
+ ficlFileOpen(vm, "a");
}
-static void ficlCreateFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+static void ficlPrimitiveCreateFile(ficlVm *vm) /* ( c-addr u fam -- fileid ior ) */
{
- ficlFopen(pVM, "w");
+ ficlFileOpen(vm, "w");
}
-static int closeFiclFILE(ficlFILE *ff) /* ( fileid -- ior ) */
+static int ficlFileClose(ficlFile *ff) /* ( fileid -- ior ) */
{
FILE *f = ff->f;
free(ff);
return !fclose(f);
}
-static void ficlCloseFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+static void ficlPrimitiveCloseFile(ficlVm *vm) /* ( fileid -- ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- pushIor(pVM, closeFiclFILE(ff));
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ pushIor(vm, ficlFileClose(ff));
}
-static void ficlDeleteFile(FICL_VM *pVM) /* ( c-addr u -- ior ) */
+static void ficlPrimitiveDeleteFile(ficlVm *vm) /* ( c-addr u -- ior ) */
{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
- char *filename = (char *)alloca(length + 1);
+ char *filename = (char *)malloc(length + 1);
memcpy(filename, address, length);
filename[length] = 0;
- pushIor(pVM, !unlink(filename));
+ pushIor(vm, !unlink(filename));
+ free(filename);
}
-static void ficlRenameFile(FICL_VM *pVM) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
+static void ficlPrimitiveRenameFile(ficlVm *vm) /* ( 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);
+ length = ficlStackPopInteger(vm->dataStack);
+ address = (void *)ficlStackPopPointer(vm->dataStack);
+ to = (char *)malloc(length + 1);
memcpy(to, address, length);
to[length] = 0;
- length = stackPopINT(pVM->pStack);
- address = (void *)stackPopPtr(pVM->pStack);
+ length = ficlStackPopInteger(vm->dataStack);
+ address = (void *)ficlStackPopPointer(vm->dataStack);
- from = (char *)alloca(length + 1);
+ from = (char *)malloc(length + 1);
memcpy(from, address, length);
from[length] = 0;
- pushIor(pVM, !rename(from, to));
+ pushIor(vm, !rename(from, to));
+
+ free(from);
+ free(to);
}
-static void ficlFileStatus(FICL_VM *pVM) /* ( c-addr u -- x ior ) */
+static void ficlPrimitiveFileStatus(ficlVm *vm) /* ( c-addr u -- x ior ) */
{
- struct stat statbuf;
+ int status;
+ int ior;
+
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *filename = (char *)alloca(length + 1);
+ char *filename = (char *)malloc(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);
- }
-}
-
+ ior = ficlFileStatus(filename, &status);
+ free(filename);
-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);
+ ficlStackPushInteger(vm->dataStack, status);
+ ficlStackPushInteger(vm->dataStack, ior);
}
-
-static long fileSize(FILE *f)
+static void ficlPrimitiveFilePosition(ficlVm *vm) /* ( fileid -- ud ior ) */
{
- struct stat statbuf;
- statbuf.st_size = -1;
- if (fstat(fileno(f), &statbuf) != 0)
- return -1;
- return statbuf.st_size;
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ long ud = ftell(ff->f);
+ ficlStackPushInteger(vm->dataStack, ud);
+ pushIor(vm, ud != -1);
}
-static void ficlFileSize(FICL_VM *pVM) /* ( fileid -- ud ior ) */
+static void ficlPrimitiveFileSize(ficlVm *vm) /* ( fileid -- ud ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- long ud = fileSize(ff->f);
- stackPushINT(pVM->pStack, ud);
- pushIor(pVM, ud != -1);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ long ud = ficlFileSize(ff);
+ ficlStackPushInteger(vm->dataStack, ud);
+ pushIor(vm, ud != -1);
}
#define nLINEBUF 256
-static void ficlIncludeFile(FICL_VM *pVM) /* ( i*x fileid -- j*x ) */
+static void ficlPrimitiveIncludeFile(ficlVm *vm) /* ( i*x fileid -- j*x ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- CELL id = pVM->sourceID;
- int result = VM_OUTOFTEXT;
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ ficlCell id = vm->sourceId;
+ int except = FICL_VM_STATUS_OUT_OF_TEXT;
long currentPosition, totalSize;
long size;
- pVM->sourceID.p = (void *)ff;
+ ficlString s;
+ vm->sourceId.p = (void *)ff;
currentPosition = ftell(ff->f);
- totalSize = fileSize(ff->f);
+ totalSize = ficlFileSize(ff);
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;
- }
+ {
+ FICL_STRING_SET_POINTER(s, buffer);
+ FICL_STRING_SET_LENGTH(s, size);
+ except = ficlVmExecuteString(vm, s);
+ }
}
-#endif /* 0 */
+
+ if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT))
+ ficlVmThrow(vm, except);
+
/*
** Pass an empty line with SOURCE-ID == -1 to flush
** any pending REFILLs (as required by FILE wordset)
*/
- pVM->sourceID.i = -1;
- ficlExec(pVM, "");
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_FROM_CSTRING(s, "");
+ ficlVmExecuteString(vm, s);
- pVM->sourceID = id;
- closeFiclFILE(ff);
+ vm->sourceId = id;
+ ficlFileClose(ff);
}
-static void ficlReadFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 ior ) */
+static void ficlPrimitiveReadFile(ficlVm *vm) /* ( c-addr u1 fileid -- u2 ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
int result;
clearerr(ff->f);
result = fread(address, 1, length, ff->f);
- stackPushINT(pVM->pStack, result);
- pushIor(pVM, ferror(ff->f) == 0);
+ ficlStackPushInteger(vm->dataStack, result);
+ pushIor(vm, ferror(ff->f) == 0);
}
-static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
+static void ficlPrimitiveReadLine(ficlVm *vm) /* ( c-addr u1 fileid -- u2 flag ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- char *address = (char *)stackPopPtr(pVM->pStack);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ char *address = (char *)ficlStackPopPointer(vm->dataStack);
int error;
int flag;
if (feof(ff->f))
{
- stackPushINT(pVM->pStack, -1);
- stackPushINT(pVM->pStack, 0);
- stackPushINT(pVM->pStack, 0);
+ ficlStackPushInteger(vm->dataStack, -1);
+ ficlStackPushInteger(vm->dataStack, 0);
+ ficlStackPushInteger(vm->dataStack, 0);
return;
}
@@ -309,9 +266,9 @@ static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
error = ferror(ff->f);
if (error != 0)
{
- stackPushINT(pVM->pStack, -1);
- stackPushINT(pVM->pStack, 0);
- stackPushINT(pVM->pStack, error);
+ ficlStackPushInteger(vm->dataStack, -1);
+ ficlStackPushInteger(vm->dataStack, 0);
+ ficlStackPushInteger(vm->dataStack, error);
return;
}
@@ -320,104 +277,111 @@ static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
length--;
- stackPushINT(pVM->pStack, length);
- stackPushINT(pVM->pStack, flag);
- stackPushINT(pVM->pStack, 0); /* ior */
+ ficlStackPushInteger(vm->dataStack, length);
+ ficlStackPushInteger(vm->dataStack, flag);
+ ficlStackPushInteger(vm->dataStack, 0); /* ior */
}
-static void ficlWriteFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+static void ficlPrimitiveWriteFile(ficlVm *vm) /* ( c-addr u1 fileid -- ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
clearerr(ff->f);
fwrite(address, 1, length, ff->f);
- pushIor(pVM, ferror(ff->f) == 0);
+ pushIor(vm, ferror(ff->f) == 0);
}
-static void ficlWriteLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+static void ficlPrimitiveWriteLine(ficlVm *vm) /* ( 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);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t length = (size_t)ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
clearerr(ff->f);
if (fwrite(address, 1, length, ff->f) == length)
fwrite("\n", 1, 1, ff->f);
- pushIor(pVM, ferror(ff->f) == 0);
+ pushIor(vm, ferror(ff->f) == 0);
}
-static void ficlRepositionFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+static void ficlPrimitiveRepositionFile(ficlVm *vm) /* ( ud fileid -- ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- size_t ud = (size_t)stackPopINT(pVM->pStack);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
- pushIor(pVM, fseek(ff->f, ud, SEEK_SET) == 0);
+ pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0);
}
-static void ficlFlushFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+static void ficlPrimitiveFlushFile(ficlVm *vm) /* ( fileid -- ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- pushIor(pVM, fflush(ff->f) == 0);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ pushIor(vm, fflush(ff->f) == 0);
}
-#if FICL_HAVE_FTRUNCATE
+#if FICL_PLATFORM_HAS_FTRUNCATE
-static void ficlResizeFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+static void ficlPrimitiveResizeFile(ficlVm *vm) /* ( ud fileid -- ior ) */
{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- size_t ud = (size_t)stackPopINT(pVM->pStack);
+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
- pushIor(pVM, ftruncate(fileno(ff->f), ud) == 0);
+ pushIor(vm, ficlFileTruncate(ff, ud) == 0);
}
-#endif /* FICL_HAVE_FTRUNCATE */
+#endif /* FICL_PLATFORM_HAS_FTRUNCATE */
#endif /* FICL_WANT_FILE */
-void ficlCompileFile(FICL_SYSTEM *pSys)
+void ficlSystemCompileFile(ficlSystem *system)
{
-#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 */
+#if !FICL_WANT_FILE
+ FICL_IGNORE(system);
#else
- &pSys;
-#endif /* FICL_WANT_FILE */
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+ ficlDictionarySetPrimitive(dictionary, "create-file", ficlPrimitiveCreateFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "open-file", ficlPrimitiveOpenFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "close-file", ficlPrimitiveCloseFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "include-file", ficlPrimitiveIncludeFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "read-file", ficlPrimitiveReadFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "read-line", ficlPrimitiveReadLine, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "write-file", ficlPrimitiveWriteFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "write-line", ficlPrimitiveWriteLine, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-position", ficlPrimitiveFilePosition, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-size", ficlPrimitiveFileSize, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "reposition-file", ficlPrimitiveRepositionFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-status", ficlPrimitiveFileStatus, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "flush-file", ficlPrimitiveFlushFile, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetPrimitive(dictionary, "delete-file", ficlPrimitiveDeleteFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "rename-file", ficlPrimitiveRenameFile, FICL_WORD_DEFAULT);
+
+#if FICL_PLATFORM_HAS_FTRUNCATE
+ ficlDictionarySetPrimitive(dictionary, "resize-file", ficlPrimitiveResizeFile, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetConstant(environment, "file", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "file-ext", FICL_TRUE);
+#else /* FICL_PLATFORM_HAS_FTRUNCATE */
+ ficlDictionarySetConstant(environment, "file", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "file-ext", FICL_FALSE);
+#endif /* FICL_PLATFORM_HAS_FTRUNCATE */
+
+#endif /* !FICL_WANT_FILE */
}
diff --git a/float.c b/float.c
index 106eb8c68964..43d841bcf421 100644
--- 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.8 2001-12-04 17:58:16-08 jsadler Exp jsadler $
+** $Id: float.c,v 1.10 2010/09/13 18:43:04 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -12,9 +12,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -50,295 +50,98 @@
#if FICL_WANT_FLOAT
-/*******************************************************************
-** Do float addition r1 + r2.
-** f+ ( r1 r2 -- r )
-*******************************************************************/
-static void Fadd(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 1);
-#endif
-
- f = POPFLOAT();
- f += GETTOPF().f;
- SETTOPF(f);
-}
/*******************************************************************
-** Do float subtraction r1 - r2.
-** f- ( r1 r2 -- r )
+** Create a floating point constant.
+** fconstant ( r -"name"- )
*******************************************************************/
-static void Fsub(FICL_VM *pVM)
+static void ficlPrimitiveFConstant(ficlVm *vm)
{
- FICL_FLOAT f;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 1);
-#endif
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
- f = POPFLOAT();
- f = GETTOPF().f - f;
- SETTOPF(f);
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
}
-/*******************************************************************
-** Do float multiplication r1 * r2.
-** f* ( r1 r2 -- r )
-*******************************************************************/
-static void Fmul(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 1);
-#endif
- f = POPFLOAT();
- f *= GETTOPF().f;
- SETTOPF(f);
-}
-
-/*******************************************************************
-** Do float negation.
-** fnegate ( r -- r )
-*******************************************************************/
-static void Fnegate(FICL_VM *pVM)
+ficlWord *ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name, float value)
{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
-#endif
-
- f = -GETTOPF().f;
- SETTOPF(f);
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppendConstantInstruction(dictionary, s, ficlInstructionFConstantParen, *(ficlInteger *)(&value));
}
-/*******************************************************************
-** Do float division r1 / r2.
-** f/ ( r1 r2 -- r )
-*******************************************************************/
-static void Fdiv(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 1);
-#endif
- f = POPFLOAT();
- f = GETTOPF().f / f;
- SETTOPF(f);
-}
-
-/*******************************************************************
-** Do float + integer r + n.
-** f+i ( r n -- r )
-*******************************************************************/
-static void Faddi(FICL_VM *pVM)
+ficlWord *ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name, float value)
{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
-
- f = (FICL_FLOAT)POPINT();
- f += GETTOPF().f;
- SETTOPF(f);
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySetConstantInstruction(dictionary, s, ficlInstructionFConstantParen, *(ficlInteger *)(&value));
}
-/*******************************************************************
-** Do float - integer r - n.
-** f-i ( r n -- r )
-*******************************************************************/
-static void Fsubi(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
- f = GETTOPF().f;
- f -= (FICL_FLOAT)POPINT();
- SETTOPF(f);
-}
-/*******************************************************************
-** Do float * integer r * n.
-** f*i ( r n -- r )
-*******************************************************************/
-static void Fmuli(FICL_VM *pVM)
+static void ficlPrimitiveF2Constant(ficlVm *vm)
{
- FICL_FLOAT f;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
+ FICL_STACK_CHECK(vm->floatStack, 2, 0);
- f = (FICL_FLOAT)POPINT();
- f *= GETTOPF().f;
- SETTOPF(f);
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionF2ConstantParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
}
-/*******************************************************************
-** Do float / integer r / n.
-** f/i ( r n -- r )
-*******************************************************************/
-static void Fdivi(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
- f = GETTOPF().f;
- f /= (FICL_FLOAT)POPINT();
- SETTOPF(f);
-}
-
-/*******************************************************************
-** Do integer - float n - r.
-** i-f ( n r -- r )
-*******************************************************************/
-static void isubf(FICL_VM *pVM)
+ficlWord *ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name, double value)
{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
-
- f = (FICL_FLOAT)POPINT();
- f -= GETTOPF().f;
- SETTOPF(f);
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppend2ConstantInstruction(dictionary, s, ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value));
}
-/*******************************************************************
-** Do integer / float n / r.
-** i/f ( n r -- r )
-*******************************************************************/
-static void idivf(FICL_VM *pVM)
-{
- FICL_FLOAT f;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1,1);
- vmCheckStack(pVM, 1, 0);
-#endif
-
- f = (FICL_FLOAT)POPINT();
- f /= GETTOPF().f;
- SETTOPF(f);
-}
-/*******************************************************************
-** Do integer to float conversion.
-** int>float ( n -- r )
-*******************************************************************/
-static void itof(FICL_VM *pVM)
+ficlWord *ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name, double value)
{
- float f;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
- vmCheckFStack(pVM, 0, 1);
-#endif
-
- f = (float)POPINT();
- PUSHFLOAT(f);
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value));
}
-/*******************************************************************
-** Do float to integer conversion.
-** float>int ( r -- n )
-*******************************************************************/
-static void Ftoi(FICL_VM *pVM)
-{
- FICL_INT i;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
- vmCheckFStack(pVM, 1, 0);
-#endif
-
- i = (FICL_INT)POPFLOAT();
- PUSHINT(i);
-}
-
-/*******************************************************************
-** Floating point constant execution word.
-*******************************************************************/
-void FconstantParen(FICL_VM *pVM)
-{
- FICL_WORD *pFW = pVM->runningWord;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 0, 1);
-#endif
-
- PUSHFLOAT(pFW->param[0].f);
-}
-
-/*******************************************************************
-** Create a floating point constant.
-** fconstant ( r -"name"- )
-*******************************************************************/
-static void Fconstant(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
-#endif
-
- dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT);
- dictAppendCell(dp, stackPop(pVM->fStack));
-}
/*******************************************************************
** Display a float in decimal format.
** f. ( r -- )
*******************************************************************/
-static void FDot(FICL_VM *pVM)
+static void ficlPrimitiveFDot(ficlVm *vm)
{
float f;
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
-#endif
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
- f = POPFLOAT();
- sprintf(pVM->pad,"%#f ",f);
- vmTextOut(pVM, pVM->pad, 0);
+ f = ficlStackPopFloat(vm->floatStack);
+ sprintf(vm->pad,"%#f ",f);
+ ficlVmTextOut(vm, vm->pad);
}
/*******************************************************************
** Display a float in engineering format.
** fe. ( r -- )
*******************************************************************/
-static void EDot(FICL_VM *pVM)
+static void ficlPrimitiveEDot(ficlVm *vm)
{
float f;
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
-#endif
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
- f = POPFLOAT();
- sprintf(pVM->pad,"%#e ",f);
- vmTextOut(pVM, pVM->pad, 0);
+ f = ficlStackPopFloat(vm->floatStack);
+ sprintf(vm->pad,"%#e ",f);
+ ficlVmTextOut(vm, vm->pad);
}
/**************************************************************************
@@ -346,466 +149,80 @@ static void EDot(FICL_VM *pVM)
** Display the parameter stack (code for "f.s")
** f.s ( -- )
**************************************************************************/
-static void displayFStack(FICL_VM *pVM)
-{
- int d = stackDepth(pVM->fStack);
- int i;
- CELL *pCell;
-
- vmCheckFStack(pVM, 0, 0);
-
- vmTextOut(pVM, "F:", 0);
-
- if (d == 0)
- vmTextOut(pVM, "[0]", 0);
- else
- {
- ltoa(d, &pVM->pad[1], pVM->base);
- pVM->pad[0] = '[';
- strcat(pVM->pad,"] ");
- vmTextOut(pVM,pVM->pad,0);
-
- pCell = pVM->fStack->sp - d;
- for (i = 0; i < d; i++)
- {
- sprintf(pVM->pad,"%#f ",(*pCell++).f);
- vmTextOut(pVM,pVM->pad,0);
- }
- }
-}
-
-/*******************************************************************
-** Do float stack depth.
-** fdepth ( -- n )
-*******************************************************************/
-static void Fdepth(FICL_VM *pVM)
-{
- int i;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- i = stackDepth(pVM->fStack);
- PUSHINT(i);
-}
-
-/*******************************************************************
-** Do float stack drop.
-** fdrop ( r -- )
-*******************************************************************/
-static void Fdrop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
-#endif
-
- DROPF(1);
-}
-
-/*******************************************************************
-** Do float stack 2drop.
-** f2drop ( r r -- )
-*******************************************************************/
-static void FtwoDrop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 0);
-#endif
-
- DROPF(2);
-}
-
-/*******************************************************************
-** Do float stack dup.
-** fdup ( r -- r r )
-*******************************************************************/
-static void Fdup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 2);
-#endif
-
- PICKF(0);
-}
-
-/*******************************************************************
-** Do float stack 2dup.
-** f2dup ( r1 r2 -- r1 r2 r1 r2 )
-*******************************************************************/
-static void FtwoDup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 4);
-#endif
-
- PICKF(1);
- PICKF(1);
-}
-
-/*******************************************************************
-** Do float stack over.
-** fover ( r1 r2 -- r1 r2 r1 )
-*******************************************************************/
-static void Fover(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 3);
-#endif
-
- PICKF(1);
-}
-
-/*******************************************************************
-** Do float stack 2over.
-** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
-*******************************************************************/
-static void FtwoOver(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 4, 6);
-#endif
-
- PICKF(3);
- PICKF(3);
-}
-
-/*******************************************************************
-** Do float stack pick.
-** fpick ( n -- r )
-*******************************************************************/
-static void Fpick(FICL_VM *pVM)
-{
- CELL c = POP();
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, c.i+1, c.i+2);
-#endif
-
- PICKF(c.i);
-}
-
-/*******************************************************************
-** Do float stack ?dup.
-** f?dup ( r -- r )
-*******************************************************************/
-static void FquestionDup(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 2);
-#endif
-
- c = GETTOPF();
- if (c.f != 0)
- PICKF(0);
-}
-
-/*******************************************************************
-** Do float stack roll.
-** froll ( n -- )
-*******************************************************************/
-static void Froll(FICL_VM *pVM)
-{
- int i = POP().i;
- i = (i > 0) ? i : 0;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, i+1, i+1);
-#endif
-
- ROLLF(i);
-}
-
-/*******************************************************************
-** Do float stack -roll.
-** f-roll ( n -- )
-*******************************************************************/
-static void FminusRoll(FICL_VM *pVM)
-{
- int i = POP().i;
- i = (i > 0) ? i : 0;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, i+1, i+1);
-#endif
-
- ROLLF(-i);
-}
-
-/*******************************************************************
-** Do float stack rot.
-** frot ( r1 r2 r3 -- r2 r3 r1 )
-*******************************************************************/
-static void Frot(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 3, 3);
-#endif
-
- ROLLF(2);
-}
-
-/*******************************************************************
-** Do float stack -rot.
-** f-rot ( r1 r2 r3 -- r3 r1 r2 )
-*******************************************************************/
-static void Fminusrot(FICL_VM *pVM)
+struct stackContext
{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 3, 3);
-#endif
+ ficlVm *vm;
+ int count;
+};
- ROLLF(-2);
-}
-
-/*******************************************************************
-** Do float stack swap.
-** fswap ( r1 r2 -- r2 r1 )
-*******************************************************************/
-static void Fswap(FICL_VM *pVM)
+static ficlInteger ficlFloatStackDisplayCallback(void *c, ficlCell *cell)
{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 2);
-#endif
-
- ROLLF(1);
+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[64];
+ sprintf(buffer, "[0x%08x %3d] %16f (0x%08x)\n", cell, context->count++, (double)(cell->f), cell->i);
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
}
-/*******************************************************************
-** Do float stack 2swap
-** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
-*******************************************************************/
-static void FtwoSwap(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 4, 4);
-#endif
- ROLLF(3);
- ROLLF(3);
-}
-/*******************************************************************
-** Get a floating point number from a variable.
-** f@ ( n -- r )
-*******************************************************************/
-static void Ffetch(FICL_VM *pVM)
+void ficlVmDisplayFloatStack(ficlVm *vm)
{
- CELL *pCell;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 0, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
-
- pCell = (CELL *)POPPTR();
- PUSHFLOAT(pCell->f);
+ struct stackContext context;
+ context.vm = vm;
+ context.count = 0;
+ ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback, &context);
+ return;
}
-/*******************************************************************
-** Store a floating point number into a variable.
-** f! ( r n -- )
-*******************************************************************/
-static void Fstore(FICL_VM *pVM)
-{
- CELL *pCell;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
- vmCheckStack(pVM, 1, 0);
-#endif
- pCell = (CELL *)POPPTR();
- pCell->f = POPFLOAT();
-}
/*******************************************************************
-** Add a floating point number to contents of a variable.
-** f+! ( r n -- )
+** Do float stack depth.
+** fdepth ( -- n )
*******************************************************************/
-static void FplusStore(FICL_VM *pVM)
+static void ficlPrimitiveFDepth(ficlVm *vm)
{
- CELL *pCell;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
- vmCheckFStack(pVM, 1, 0);
-#endif
-
- pCell = (CELL *)POPPTR();
- pCell->f += POPFLOAT();
-}
+ int i;
-/*******************************************************************
-** Floating point literal execution word.
-*******************************************************************/
-static void fliteralParen(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
- PUSHFLOAT(*(float*)(pVM->ip));
- vmBranchRelative(pVM, 1);
+ i = ficlStackDepth(vm->floatStack);
+ ficlStackPushInteger(vm->dataStack, i);
}
/*******************************************************************
** Compile a floating point literal.
*******************************************************************/
-static void fliteralIm(FICL_VM *pVM)
+static void ficlPrimitiveFLiteralImmediate(ficlVm *vm)
{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)");
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlCell cell;
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
-#endif
- dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
- dictAppendCell(dp, stackPop(pVM->fStack));
-}
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
-/*******************************************************************
-** Do float 0= comparison r = 0.0.
-** f0= ( r -- T/F )
-*******************************************************************/
-static void FzeroEquals(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
- vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
-#endif
-
- c.i = FICL_BOOL(POPFLOAT() == 0);
- PUSH(c);
-}
-
-/*******************************************************************
-** Do float 0< comparison r < 0.0.
-** f0< ( r -- T/F )
-*******************************************************************/
-static void FzeroLess(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
- vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
-#endif
-
- c.i = FICL_BOOL(POPFLOAT() < 0);
- PUSH(c);
-}
-
-/*******************************************************************
-** Do float 0> comparison r > 0.0.
-** f0> ( r -- T/F )
-*******************************************************************/
-static void FzeroGreater(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
- vmCheckStack(pVM, 0, 1);
-#endif
-
- c.i = FICL_BOOL(POPFLOAT() > 0);
- PUSH(c);
-}
-
-/*******************************************************************
-** Do float = comparison r1 = r2.
-** f= ( r1 r2 -- T/F )
-*******************************************************************/
-static void FisEqual(FICL_VM *pVM)
-{
- float x, y;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 0);
- vmCheckStack(pVM, 0, 1);
-#endif
-
- x = POPFLOAT();
- y = POPFLOAT();
- PUSHINT(FICL_BOOL(x == y));
-}
-
-/*******************************************************************
-** Do float < comparison r1 < r2.
-** f< ( r1 r2 -- T/F )
-*******************************************************************/
-static void FisLess(FICL_VM *pVM)
-{
- float x, y;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 0);
- vmCheckStack(pVM, 0, 1);
-#endif
- y = POPFLOAT();
- x = POPFLOAT();
- PUSHINT(FICL_BOOL(x < y));
+ cell = ficlStackPop(vm->floatStack);
+ if (cell.f == 1.0f)
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1);
+ }
+ else if (cell.f == 0.0f)
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0);
+ }
+ else if (cell.f == -1.0f)
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1);
+ }
+ else
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFLiteralParen);
+ ficlDictionaryAppendCell(dictionary, cell);
+ }
}
-/*******************************************************************
-** Do float > comparison r1 > r2.
-** f> ( r1 r2 -- T/F )
-*******************************************************************/
-static void FisGreater(FICL_VM *pVM)
-{
- float x, y;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 2, 0);
- vmCheckStack(pVM, 0, 1);
-#endif
-
- y = POPFLOAT();
- x = POPFLOAT();
- PUSHINT(FICL_BOOL(x > y));
-}
-
-
-/*******************************************************************
-** Move float to param stack (assumes they both fit in a single CELL)
-** f>s
-*******************************************************************/
-static void FFrom(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 1, 0);
- vmCheckStack(pVM, 0, 1);
-#endif
-
- c = stackPop(pVM->fStack);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void ToF(FICL_VM *pVM)
-{
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 0, 1);
- vmCheckStack(pVM, 1, 0);
-#endif
-
- c = stackPop(pVM->pStack);
- stackPush(pVM->fStack, c);
- return;
-}
-
-
/**************************************************************************
F l o a t P a r s e S t a t e
** Enum to determine the current segement of a floating point number
@@ -825,38 +242,39 @@ typedef enum _floatParseState
/**************************************************************************
f i c l P a r s e F l o a t N u m b e r
-** pVM -- Virtual Machine pointer.
-** si -- String to parse.
+** vm -- Virtual Machine pointer.
+** s -- String to parse.
** Returns 1 if successful, 0 if not.
**************************************************************************/
-int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
+int ficlVmParseFloatNumber( ficlVm *vm, ficlString s)
{
- unsigned char ch, digit;
- char *cp;
- FICL_COUNT count;
+ unsigned char c;
+ unsigned char digit;
+ char *trace;
+ ficlUnsigned length;
float power;
float accum = 0.0f;
float mant = 0.1f;
- FICL_INT exponent = 0;
+ ficlInteger exponent = 0;
char flag = 0;
FloatParseState estate = FPS_START;
-#if FICL_ROBUST > 1
- vmCheckFStack(pVM, 0, 1);
-#endif
+ FICL_STACK_CHECK(vm->floatStack, 0, 1);
+
+
/*
** floating point numbers only allowed in base 10
*/
- if (pVM->base != 10)
+ if (vm->base != 10)
return(0);
- cp = SI_PTR(si);
- count = (FICL_COUNT)SI_COUNT(si);
+ trace = FICL_STRING_GET_POINTER(s);
+ length = FICL_STRING_GET_LENGTH(s);
/* Loop through the string's characters. */
- while ((count--) && ((ch = *cp++) != 0))
+ while ((length--) && ((c = *trace++) != 0))
{
switch (estate)
{
@@ -864,12 +282,12 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
case FPS_START:
{
estate = FPS_ININT;
- if (ch == '-')
+ if (c == '-')
{
flag |= NUMISNEG;
break;
}
- if (ch == '+')
+ if (c == '+')
{
break;
}
@@ -880,17 +298,17 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
*/
case FPS_ININT:
{
- if (ch == '.')
+ if (c == '.')
{
estate = FPS_INMANT;
}
- else if ((ch == 'e') || (ch == 'E'))
+ else if ((c == 'e') || (c == 'E'))
{
estate = FPS_STARTEXP;
}
else
{
- digit = (unsigned char)(ch - '0');
+ digit = (unsigned char)(c - '0');
if (digit > 9)
return(0);
@@ -905,13 +323,13 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
*/
case FPS_INMANT:
{
- if ((ch == 'e') || (ch == 'E'))
+ if ((c == 'e') || (c == 'E'))
{
estate = FPS_STARTEXP;
}
else
{
- digit = (unsigned char)(ch - '0');
+ digit = (unsigned char)(c - '0');
if (digit > 9)
return(0);
@@ -926,12 +344,12 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
{
estate = FPS_INEXP;
- if (ch == '-')
+ if (c == '-')
{
flag |= EXPISNEG;
break;
}
- else if (ch == '+')
+ else if (c == '+')
{
break;
}
@@ -942,7 +360,7 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
*/
case FPS_INEXP:
{
- digit = (unsigned char)(ch - '0');
+ digit = (unsigned char)(c - '0');
if (digit > 9)
return(0);
@@ -974,92 +392,78 @@ int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
accum *= power;
}
- PUSHFLOAT(accum);
- if (pVM->state == COMPILE)
- fliteralIm(pVM);
+ ficlStackPushFloat(vm->floatStack, accum);
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ ficlPrimitiveFLiteralImmediate(vm);
return(1);
}
+
+#if FICL_WANT_LOCALS
+
+static void ficlPrimitiveFLocalParen(ficlVm *vm)
+{
+ ficlLocalParen(vm, 0, 1);
+}
+
+static void ficlPrimitiveF2LocalParen(ficlVm *vm)
+{
+ ficlLocalParen(vm, 1, 1);
+}
+
+#endif /* FICL_WANT_LOCALS */
+
#endif /* FICL_WANT_FLOAT */
/**************************************************************************
** Add float words to a system's dictionary.
-** pSys -- Pointer to the FICL sytem to add float words to.
+** system -- Pointer to the Ficl sytem to add float words to.
**************************************************************************/
-void ficlCompileFloat(FICL_SYSTEM *pSys)
+void ficlSystemCompileFloat(ficlSystem *system)
{
- FICL_DICT *dp = pSys->dp;
- assert(dp);
-
#if FICL_WANT_FLOAT
- dictAppendWord(dp, ">float", ToF, FW_DEFAULT);
- /* d>f */
- dictAppendWord(dp, "f!", Fstore, FW_DEFAULT);
- dictAppendWord(dp, "f*", Fmul, FW_DEFAULT);
- dictAppendWord(dp, "f+", Fadd, FW_DEFAULT);
- dictAppendWord(dp, "f-", Fsub, FW_DEFAULT);
- dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT);
- dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT);
- dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT);
- dictAppendWord(dp, "f<", FisLess, FW_DEFAULT);
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+ ficlDictionarySetPrimitive(dictionary, "fconstant", ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fvalue", ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f2constant", ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f2value", ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fdepth", ficlPrimitiveFDepth, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fliteral", ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "f.", ficlPrimitiveFDot, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f.s", ficlVmDisplayFloatStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fe.", ficlPrimitiveEDot, FICL_WORD_DEFAULT);
+
+#if FICL_WANT_LOCALS
+ ficlDictionarySetPrimitive(dictionary, "(flocal)", ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY);
+ ficlDictionarySetPrimitive(dictionary, "(f2local)", ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY);
+#endif /* FICL_WANT_LOCALS */
+
/*
+ Missing words:
+
+ d>f
f>d
- */
- dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT);
- /*
falign
faligned
- */
- dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT);
- dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT);
- dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT);
- dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT);
- dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE);
-/*
float+
floats
floor
fmax
fmin
*/
- dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT);
- dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT);
- dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT);
- dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT);
- dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT);
- dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT);
- dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT);
- dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT);
- dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT);
- dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT);
- dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT);
- dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT);
- dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT);
- dictAppendWord(dp, "int>float", itof, FW_DEFAULT);
- dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT);
- dictAppendWord(dp, "f.", FDot, FW_DEFAULT);
- dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT);
- dictAppendWord(dp, "fe.", EDot, FW_DEFAULT);
- dictAppendWord(dp, "fover", Fover, FW_DEFAULT);
- dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT);
- dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT);
- dictAppendWord(dp, "froll", Froll, FW_DEFAULT);
- dictAppendWord(dp, "frot", Frot, FW_DEFAULT);
- dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT);
- dictAppendWord(dp, "i-f", isubf, FW_DEFAULT);
- dictAppendWord(dp, "i/f", idivf, FW_DEFAULT);
-
- dictAppendWord(dp, "float>", FFrom, FW_DEFAULT);
-
- dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
- dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
- dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
-
- ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */
- ficlSetEnv(pSys, "floating-ext", FICL_FALSE);
- ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK);
+
+ ficlDictionarySetConstant(environment, "floating", FICL_FALSE); /* not all required words are present */
+ ficlDictionarySetConstant(environment, "floating-ext", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "floating-stack", system->stackSize);
+#else /* FICL_WANT_FLOAT */
+ /* get rid of unused parameter warning */
+ system = NULL;
#endif
return;
}
-
diff --git a/hash.c b/hash.c
new file mode 100644
index 000000000000..129979e8176e
--- /dev/null
+++ b/hash.c
@@ -0,0 +1,163 @@
+#include <ctype.h>
+
+#include "ficl.h"
+
+
+#define FICL_ASSERT_PHASH(hash, expression) FICL_ASSERT(NULL, expression)
+
+
+
+/**************************************************************************
+ h a s h F o r g e t
+** Unlink all words in the hash that have addresses greater than or
+** equal to the address supplied. Implementation factor for FORGET
+** and MARKER.
+**************************************************************************/
+void ficlHashForget(ficlHash *hash, void *where)
+{
+ ficlWord *pWord;
+ unsigned i;
+
+ FICL_ASSERT_PHASH(hash, hash);
+ FICL_ASSERT_PHASH(hash, where);
+
+ for (i = 0; i < hash->size; i++)
+ {
+ pWord = hash->table[i];
+
+ while ((void *)pWord >= where)
+ {
+ pWord = pWord->link;
+ }
+
+ hash->table[i] = pWord;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ h a s h H a s h C o d e
+**
+** Generate a 16 bit hashcode from a character string using a rolling
+** shift and add stolen from PJ Weinberger of Bell Labs fame. Case folds
+** the name before hashing it...
+** N O T E : If string has zero length, returns zero.
+**************************************************************************/
+ficlUnsigned16 ficlHashCode(ficlString s)
+{
+ /* hashPJW */
+ ficlUnsigned8 *trace;
+ ficlUnsigned16 code = (ficlUnsigned16)s.length;
+ ficlUnsigned16 shift = 0;
+
+ if (s.length == 0)
+ return 0;
+
+ /* changed to run without errors under Purify -- lch */
+ for (trace = (ficlUnsigned8 *)s.text; s.length && *trace; trace++, s.length--)
+ {
+ code = (ficlUnsigned16)((code << 4) + tolower(*trace));
+ shift = (ficlUnsigned16)(code & 0xf000);
+ if (shift)
+ {
+ code ^= (ficlUnsigned16)(shift >> 8);
+ code ^= (ficlUnsigned16)shift;
+ }
+ }
+
+ return (ficlUnsigned16)code;
+}
+
+
+
+
+/**************************************************************************
+ h a s h I n s e r t W o r d
+** Put a word into the hash table using the word's hashcode as
+** an index (modulo the table size).
+**************************************************************************/
+void ficlHashInsertWord(ficlHash *hash, ficlWord *word)
+{
+ ficlWord **pList;
+
+ FICL_ASSERT_PHASH(hash, hash);
+ FICL_ASSERT_PHASH(hash, word);
+
+ if (hash->size == 1)
+ {
+ pList = hash->table;
+ }
+ else
+ {
+ pList = hash->table + (word->hash % hash->size);
+ }
+
+ word->link = *pList;
+ *pList = word;
+ return;
+}
+
+
+/**************************************************************************
+ h a s h L o o k u p
+** Find a name in the hash table given the hashcode and text of the name.
+** Returns the address of the corresponding ficlWord if found,
+** otherwise NULL.
+** Note: outer loop on link field supports inheritance in wordlists.
+** It's not part of ANS Forth - Ficl only. hashReset creates wordlists
+** with NULL link fields.
+**************************************************************************/
+ficlWord *ficlHashLookup(ficlHash *hash, ficlString name, ficlUnsigned16 hashCode)
+{
+ ficlUnsigned nCmp = name.length;
+ ficlWord *word;
+ ficlUnsigned16 hashIdx;
+
+ if (nCmp > FICL_NAME_LENGTH)
+ nCmp = FICL_NAME_LENGTH;
+
+ for (; hash != NULL; hash = hash->link)
+ {
+ if (hash->size > 1)
+ hashIdx = (ficlUnsigned16)(hashCode % hash->size);
+ else /* avoid the modulo op for single threaded lists */
+ hashIdx = 0;
+
+ for (word = hash->table[hashIdx]; word; word = word->link)
+ {
+ if ( (word->length == name.length)
+ && (!ficlStrincmp(name.text, word->name, nCmp)) )
+ return word;
+#if FICL_ROBUST
+ FICL_ASSERT_PHASH(hash, word != word->link);
+#endif
+ }
+ }
+
+ return NULL;
+}
+
+
+/**************************************************************************
+ h a s h R e s e t
+** Initialize a ficlHash to empty state.
+**************************************************************************/
+void ficlHashReset(ficlHash *hash)
+{
+ unsigned i;
+
+ FICL_ASSERT_PHASH(hash, hash);
+
+ for (i = 0; i < hash->size; i++)
+ {
+ hash->table[i] = NULL;
+ }
+
+ hash->link = NULL;
+ hash->name = NULL;
+ return;
+}
+
+
diff --git a/lzcompress.c b/lzcompress.c
new file mode 100644
index 000000000000..c59ec32070ff
--- /dev/null
+++ b/lzcompress.c
@@ -0,0 +1,202 @@
+#include <assert.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "ficl.h"
+
+#define NETWORK_ORDER(X) ((((unsigned char*)X[0]) << 8) | (((unsigned char *)X[1])))
+
+
+static int ficlLzCompareWindow(const unsigned char *window, const unsigned char *buffer,
+ int *offset, unsigned char *next, int windowSize, int bufferSize)
+ {
+ const unsigned char *windowEnd;
+ const unsigned char *bufferEnd;
+ int longest;
+ unsigned char bufferFirst;
+ const unsigned char *windowTrace;
+
+ longest = 0;
+ bufferFirst = buffer[0];
+ *next = bufferFirst;
+
+ /*
+ ** we can't match more than bufferSize-1 characters...
+ ** we need to reserve the last character for the "next",
+ ** and this also prevents us from returning FICL_LZ_BUFFER_LENGTH
+ ** as the length (which won't work, max we can store is FICL_LZ_BUFFER_LENGTH - 1)
+ */
+ bufferSize--;
+
+ windowEnd = window + windowSize;
+ bufferEnd = buffer + bufferSize;
+
+ for (windowTrace = window; windowTrace < windowEnd; windowTrace++)
+ {
+ const unsigned char *bufferTrace;
+ const unsigned char *windowTrace2;
+ int length;
+
+ if (*windowTrace != bufferFirst)
+ continue;
+
+ bufferTrace = buffer;
+ for (windowTrace2 = windowTrace;
+ (windowTrace2 < windowEnd) && (bufferTrace < bufferEnd)
+ && (*windowTrace2 == *bufferTrace);
+ windowTrace2++, bufferTrace++)
+ {
+ }
+
+ length = windowTrace2 - windowTrace;
+ if ((length > longest) && (length >= FICL_LZ_MINIMUM_USEFUL_MATCH))
+ {
+ *offset = windowTrace - window;
+ longest = length;
+ *next = *bufferTrace;
+ }
+ }
+
+ return longest;
+ }
+
+
+
+void ficlLzEncodeHeaderField(unsigned char *data, unsigned int input, int *byteOffset)
+ {
+ int i;
+
+ if (input <= 252)
+ data[(*byteOffset)++] = (unsigned char)input;
+ else
+ {
+ unsigned char id;
+ int length;
+ int inputPosition;
+ int bitsOffset;
+
+ if (input <= 65536)
+ {
+ id = 253;
+ length = 2;
+ }
+ else
+ {
+ id = 254;
+ length = 4;
+ }
+
+ input = ficlNetworkUnsigned32(input);
+ inputPosition = (sizeof(unsigned long) * 8) - (length * 8);
+ bitsOffset;
+
+ data[(*byteOffset)++] = (unsigned char)id;
+ bitsOffset = *byteOffset * 8;
+ (*byteOffset) += length;
+
+ for (i = 0; i < (length * 8); i++)
+ ficlBitSet(data, bitsOffset++, ficlBitGet((unsigned char *)&input, inputPosition++));
+ }
+ }
+
+
+
+int ficlLzCompress(const unsigned char *uncompressed, size_t uncompressedSize, unsigned char **compressed_p, size_t *compressedSize_p)
+ {
+ unsigned char *compressed;
+ const unsigned char *window;
+ const unsigned char *buffer;
+ int outputPosition;
+ int remaining;
+ int windowSize;
+ int headerLength;
+ unsigned char headerBuffer[10];
+ int compressedSize;
+ int totalSize;
+
+ *compressed_p = NULL;
+
+ compressed = (unsigned char *)calloc(((uncompressedSize * 5) / 4) + 10, 1);
+ if (compressed == NULL)
+ return -1;
+
+ window = buffer = uncompressed;
+
+ outputPosition = 0;
+ remaining = uncompressedSize;
+ windowSize = 0;
+
+ while (remaining > 0)
+ {
+ int bufferSize = FICL_MIN(remaining, FICL_LZ_BUFFER_SIZE);
+ int useWindowSize = FICL_MIN(remaining, windowSize);
+ int offset = 0;
+ int i;
+
+ unsigned long token;
+ int tokenLength;
+ unsigned char next;
+
+ int length = ficlLzCompareWindow(window, buffer, &offset, &next, useWindowSize, bufferSize);
+ if (length > 1)
+ {
+ /* phrase token */
+ assert((length - FICL_LZ_MINIMUM_USEFUL_MATCH) < (1 << FICL_LZ_LENGTH_BITS));
+ token = (1 << (FICL_LZ_PHRASE_BITS - 1))
+ | (offset << (FICL_LZ_PHRASE_BITS - FICL_LZ_TYPE_BITS - FICL_LZ_OFFSET_BITS))
+ | ((length - FICL_LZ_MINIMUM_USEFUL_MATCH) << (FICL_LZ_PHRASE_BITS - FICL_LZ_TYPE_BITS - FICL_LZ_OFFSET_BITS - FICL_LZ_LENGTH_BITS))
+ | next;
+
+ tokenLength = FICL_LZ_PHRASE_BITS;
+ }
+ else
+ {
+ token = next;
+ tokenLength = FICL_LZ_SYMBOL_BITS;
+ }
+
+ token = ficlNetworkUnsigned32(token);
+ for (i = 0; i < tokenLength; i++)
+ {
+ int inputPosition = (sizeof(unsigned long) * 8) - tokenLength + i;
+ ficlBitSet(compressed, outputPosition, ficlBitGet((unsigned char *)&token, inputPosition));
+ outputPosition++;
+ }
+
+ length++;
+
+ buffer += length;
+ if (windowSize == FICL_LZ_WINDOW_SIZE)
+ window += length;
+ else
+ {
+ if ((windowSize + length) < FICL_LZ_WINDOW_SIZE)
+ windowSize += length;
+ else
+ {
+ window += (windowSize + length) - FICL_LZ_WINDOW_SIZE;
+ windowSize = FICL_LZ_WINDOW_SIZE;
+ }
+ }
+
+ remaining -= length;
+ }
+
+ headerLength = 0;
+ memset(&headerBuffer, 0, sizeof(headerBuffer));
+ ficlLzEncodeHeaderField(headerBuffer, outputPosition, &headerLength);
+ ficlLzEncodeHeaderField(headerBuffer, uncompressedSize, &headerLength);
+
+ /* plug in header */
+ compressedSize = (((outputPosition - 1) / 8) + 1);
+ totalSize = compressedSize + headerLength;
+ compressed = (unsigned char *)realloc(compressed, totalSize);
+ memmove(compressed + headerLength, compressed, compressedSize);
+ memcpy(compressed, headerBuffer, headerLength);
+
+ *compressed_p = compressed;
+ *compressedSize_p = totalSize;
+
+ return 0;
+ }
+
diff --git a/lzuncompress.c b/lzuncompress.c
new file mode 100644
index 000000000000..82ede94614ff
--- /dev/null
+++ b/lzuncompress.c
@@ -0,0 +1,94 @@
+#include <stdlib.h>
+#include <string.h>
+
+#include "ficl.h"
+
+
+
+int ficlLzDecodeHeaderField(const unsigned char *data, int *byteOffset)
+ {
+ unsigned char id;
+ int networkOrder;
+ int length;
+
+ id = data[(*byteOffset)++];
+ if (id < 252)
+ return id;
+
+ networkOrder = 0;
+ length = (id == 253) ? 2: 4;
+
+ ficlBitGetString(((unsigned char *)&networkOrder), data,
+ (*byteOffset) * 8,
+ length * 8, sizeof(networkOrder) * 8);
+ (*byteOffset) += length;
+
+ return ficlNetworkUnsigned32(networkOrder);
+ }
+
+
+
+int ficlLzUncompress(const unsigned char *compressed, unsigned char **uncompressed_p, size_t *uncompressedSize_p)
+ {
+ unsigned char *window;
+ unsigned char *buffer;
+ unsigned char *uncompressed;
+ unsigned char *initialWindow;
+
+ int bitstreamLength;
+ int inputPosition;
+ int uncompressedSize;
+
+ *uncompressed_p = NULL;
+
+ inputPosition = 0;
+ bitstreamLength = ficlLzDecodeHeaderField(compressed, &inputPosition);
+ uncompressedSize = ficlLzDecodeHeaderField(compressed, &inputPosition);
+
+ inputPosition <<= 3; /* same as * 8 */
+
+ bitstreamLength += inputPosition;
+
+ uncompressed = (unsigned char *)calloc(uncompressedSize + 1, 1);
+ if (uncompressed == NULL)
+ return -1;
+ window = buffer = uncompressed;
+ initialWindow = buffer + FICL_LZ_WINDOW_SIZE;
+
+ while (inputPosition != bitstreamLength)
+ {
+ int length;
+ int token = ficlBitGet(compressed, inputPosition);
+ inputPosition++;
+
+ if (token)
+ {
+ /* phrase token */
+ int offset = 0;
+ ficlBitGetString((unsigned char *)&offset, compressed, inputPosition, FICL_LZ_PHRASE_BITS - (1 + FICL_LZ_NEXT_BITS), sizeof(offset) * 8);
+ offset = ficlNetworkUnsigned32(offset);
+ inputPosition += FICL_LZ_PHRASE_BITS - (1 + FICL_LZ_NEXT_BITS);
+
+ length = (offset & ((1 << FICL_LZ_LENGTH_BITS) - 1)) + FICL_LZ_MINIMUM_USEFUL_MATCH;
+ offset >>= FICL_LZ_LENGTH_BITS;
+
+ memmove(buffer, window + offset, length);
+ buffer += length;
+ length++;
+ }
+ else
+ length = 1;
+
+ /* symbol token */
+ *buffer = 0;
+ ficlBitGetString(buffer++, compressed, inputPosition, FICL_LZ_NEXT_BITS, sizeof(*buffer) * 8);
+ inputPosition += FICL_LZ_NEXT_BITS;
+ if (buffer > initialWindow)
+ window = buffer - FICL_LZ_WINDOW_SIZE;
+ }
+
+ *uncompressed_p = uncompressed;
+ *uncompressedSize_p = uncompressedSize;
+
+ return 0;
+ }
diff --git a/main.c b/main.c
new file mode 100644
index 000000000000..e62e15c3a6c9
--- /dev/null
+++ b/main.c
@@ -0,0 +1,78 @@
+/*
+** stub main for testing Ficl
+** $Id: main.c,v 1.2 2010/09/10 09:01:28 asau Exp $
+*/
+/*
+** 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
+** 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 <stdio.h>
+#include <stdlib.h>
+
+#include "ficl.h"
+
+
+int main(int argc, char **argv)
+{
+ int returnValue = 0;
+ char buffer[256];
+ ficlVm *vm;
+ ficlSystem *system;
+
+ system = ficlSystemCreate(NULL);
+ ficlSystemCompileExtras(system);
+ vm = ficlSystemCreateVm(system);
+
+ returnValue = ficlVmEvaluate(vm, ".ver .( " __DATE__ " ) cr quit");
+
+ /*
+ ** load files specified on command-line
+ */
+ if (argc > 1)
+ {
+ sprintf(buffer, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
+ returnValue = ficlVmEvaluate(vm, buffer);
+ }
+
+ while (returnValue != FICL_VM_STATUS_USER_EXIT)
+ {
+ fputs(FICL_PROMPT, stdout);
+ if (fgets(buffer, sizeof(buffer), stdin) == NULL) break;
+ returnValue = ficlVmEvaluate(vm, buffer);
+ }
+
+ ficlSystemDestroy(system);
+ return 0;
+}
+
diff --git a/math64.c b/math64.c
deleted file mode 100644
index 016541d998cd..000000000000
--- a/math64.c
+++ /dev/null
@@ -1,559 +0,0 @@
-/*******************************************************************
-** m a t h 6 4 . c
-** Forth Inspired Command Language - 64 bit math support routines
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 25 January 1998
-** Rev 2.03: Support for 128 bit DP math. This file really ouught to
-** be renamed!
-** $Id: math64.c,v 1.6 2001-05-16 07:56:16-07 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** 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
-** 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"
-#include "math64.h"
-
-
-/**************************************************************************
- m 6 4 A b s
-** Returns the absolute value of an DPINT
-**************************************************************************/
-DPINT m64Abs(DPINT x)
-{
- if (m64IsNegative(x))
- x = m64Negate(x);
-
- return x;
-}
-
-
-/**************************************************************************
- m 6 4 F l o o r e d D i v I
-**
-** FROM THE FORTH ANS...
-** Floored division is integer division in which the remainder carries
-** the sign of the divisor or is zero, and the quotient is rounded to
-** its arithmetic floor. Symmetric division is integer division in which
-** the remainder carries the sign of the dividend or is zero and the
-** quotient is the mathematical quotient rounded towards zero or
-** truncated. Examples of each are shown in tables 3.3 and 3.4.
-**
-** Table 3.3 - Floored Division Example
-** Dividend Divisor Remainder Quotient
-** -------- ------- --------- --------
-** 10 7 3 1
-** -10 7 4 -2
-** 10 -7 -4 -2
-** -10 -7 -3 1
-**
-**
-** Table 3.4 - Symmetric Division Example
-** Dividend Divisor Remainder Quotient
-** -------- ------- --------- --------
-** 10 7 3 1
-** -10 7 -3 -1
-** 10 -7 3 -1
-** -10 -7 -3 1
-**************************************************************************/
-INTQR m64FlooredDivI(DPINT num, FICL_INT den)
-{
- INTQR qr;
- UNSQR uqr;
- int signRem = 1;
- int signQuot = 1;
-
- if (m64IsNegative(num))
- {
- num = m64Negate(num);
- signQuot = -signQuot;
- }
-
- if (den < 0)
- {
- den = -den;
- signRem = -signRem;
- signQuot = -signQuot;
- }
-
- uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den);
- qr = m64CastQRUI(uqr);
- if (signQuot < 0)
- {
- qr.quot = -qr.quot;
- if (qr.rem != 0)
- {
- qr.quot--;
- qr.rem = den - qr.rem;
- }
- }
-
- if (signRem < 0)
- qr.rem = -qr.rem;
-
- return qr;
-}
-
-
-/**************************************************************************
- m 6 4 I s N e g a t i v e
-** Returns TRUE if the specified DPINT has its sign bit set.
-**************************************************************************/
-int m64IsNegative(DPINT x)
-{
- return (x.hi < 0);
-}
-
-
-/**************************************************************************
- m 6 4 M a c
-** Mixed precision multiply and accumulate primitive for number building.
-** Multiplies DPUNS u by FICL_UNS mul and adds FICL_UNS add. Mul is typically
-** the numeric base, and add represents a digit to be appended to the
-** growing number.
-** Returns the result of the operation
-**************************************************************************/
-DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add)
-{
- DPUNS resultLo = ficlLongMul(u.lo, mul);
- DPUNS resultHi = ficlLongMul(u.hi, mul);
- resultLo.hi += resultHi.lo;
- resultHi.lo = resultLo.lo + add;
-
- if (resultHi.lo < resultLo.lo)
- resultLo.hi++;
-
- resultLo.lo = resultHi.lo;
-
- return resultLo;
-}
-
-
-/**************************************************************************
- m 6 4 M u l I
-** Multiplies a pair of FICL_INTs and returns an DPINT result.
-**************************************************************************/
-DPINT m64MulI(FICL_INT x, FICL_INT y)
-{
- DPUNS prod;
- int sign = 1;
-
- if (x < 0)
- {
- sign = -sign;
- x = -x;
- }
-
- if (y < 0)
- {
- sign = -sign;
- y = -y;
- }
-
- prod = ficlLongMul(x, y);
- if (sign > 0)
- return m64CastUI(prod);
- else
- return m64Negate(m64CastUI(prod));
-}
-
-
-/**************************************************************************
- m 6 4 N e g a t e
-** Negates an DPINT by complementing and incrementing.
-**************************************************************************/
-DPINT m64Negate(DPINT x)
-{
- x.hi = ~x.hi;
- x.lo = ~x.lo;
- x.lo ++;
- if (x.lo == 0)
- x.hi++;
-
- return x;
-}
-
-
-/**************************************************************************
- m 6 4 P u s h
-** Push an DPINT onto the specified stack in the order required
-** by ANS Forth (most significant cell on top)
-** These should probably be macros...
-**************************************************************************/
-void i64Push(FICL_STACK *pStack, DPINT i64)
-{
- stackPushINT(pStack, i64.lo);
- stackPushINT(pStack, i64.hi);
- return;
-}
-
-void u64Push(FICL_STACK *pStack, DPUNS u64)
-{
- stackPushINT(pStack, u64.lo);
- stackPushINT(pStack, u64.hi);
- return;
-}
-
-
-/**************************************************************************
- m 6 4 P o p
-** Pops an DPINT off the stack in the order required by ANS Forth
-** (most significant cell on top)
-** These should probably be macros...
-**************************************************************************/
-DPINT i64Pop(FICL_STACK *pStack)
-{
- DPINT ret;
- ret.hi = stackPopINT(pStack);
- ret.lo = stackPopINT(pStack);
- return ret;
-}
-
-DPUNS u64Pop(FICL_STACK *pStack)
-{
- DPUNS ret;
- ret.hi = stackPopINT(pStack);
- ret.lo = stackPopINT(pStack);
- return ret;
-}
-
-
-/**************************************************************************
- m 6 4 S y m m e t r i c D i v
-** Divide an DPINT by a FICL_INT and return a FICL_INT quotient and a
-** FICL_INT remainder. The absolute values of quotient and remainder are not
-** affected by the signs of the numerator and denominator (the operation
-** is symmetric on the number line)
-**************************************************************************/
-INTQR m64SymmetricDivI(DPINT num, FICL_INT den)
-{
- INTQR qr;
- UNSQR uqr;
- int signRem = 1;
- int signQuot = 1;
-
- if (m64IsNegative(num))
- {
- num = m64Negate(num);
- signRem = -signRem;
- signQuot = -signQuot;
- }
-
- if (den < 0)
- {
- den = -den;
- signQuot = -signQuot;
- }
-
- uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den);
- qr = m64CastQRUI(uqr);
- if (signRem < 0)
- qr.rem = -qr.rem;
-
- if (signQuot < 0)
- qr.quot = -qr.quot;
-
- return qr;
-}
-
-
-/**************************************************************************
- m 6 4 U M o d
-** Divides a DPUNS by base (an UNS16) and returns an UNS16 remainder.
-** Writes the quotient back to the original DPUNS as a side effect.
-** This operation is typically used to convert an DPUNS to a text string
-** in any base. See words.c:numberSignS, for example.
-** Mechanics: performs 4 ficlLongDivs, each of which produces 16 bits
-** of the quotient. C does not provide a way to divide an FICL_UNS by an
-** UNS16 and get an FICL_UNS quotient (ldiv is closest, but it's signed,
-** unfortunately), so I've used ficlLongDiv.
-**************************************************************************/
-#if (BITS_PER_CELL == 32)
-
-#define UMOD_SHIFT 16
-#define UMOD_MASK 0x0000ffff
-
-#elif (BITS_PER_CELL == 64)
-
-#define UMOD_SHIFT 32
-#define UMOD_MASK 0x00000000ffffffff
-
-#endif
-
-UNS16 m64UMod(DPUNS *pUD, UNS16 base)
-{
- DPUNS ud;
- UNSQR qr;
- DPUNS result;
-
- result.hi = result.lo = 0;
-
- ud.hi = 0;
- ud.lo = pUD->hi >> UMOD_SHIFT;
- qr = ficlLongDiv(ud, (FICL_UNS)base);
- result.hi = qr.quot << UMOD_SHIFT;
-
- ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->hi & UMOD_MASK);
- qr = ficlLongDiv(ud, (FICL_UNS)base);
- result.hi |= qr.quot & UMOD_MASK;
-
- ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo >> UMOD_SHIFT);
- qr = ficlLongDiv(ud, (FICL_UNS)base);
- result.lo = qr.quot << UMOD_SHIFT;
-
- ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo & UMOD_MASK);
- qr = ficlLongDiv(ud, (FICL_UNS)base);
- result.lo |= qr.quot & UMOD_MASK;
-
- *pUD = result;
-
- return (UNS16)(qr.rem);
-}
-
-
-/**************************************************************************
-** Contributed by
-** Michael A. Gauland gaulandm@mdhost.cse.tek.com
-**************************************************************************/
-#if PORTABLE_LONGMULDIV != 0
-/**************************************************************************
- m 6 4 A d d
-**
-**************************************************************************/
-DPUNS m64Add(DPUNS x, DPUNS y)
-{
- DPUNS result;
- int carry;
-
- result.hi = x.hi + y.hi;
- result.lo = x.lo + y.lo;
-
-
- carry = ((x.lo | y.lo) & CELL_HI_BIT) && !(result.lo & CELL_HI_BIT);
- carry |= ((x.lo & y.lo) & CELL_HI_BIT);
-
- if (carry)
- {
- result.hi++;
- }
-
- return result;
-}
-
-
-/**************************************************************************
- m 6 4 S u b
-**
-**************************************************************************/
-DPUNS m64Sub(DPUNS x, DPUNS y)
-{
- DPUNS result;
-
- result.hi = x.hi - y.hi;
- result.lo = x.lo - y.lo;
-
- if (x.lo < y.lo)
- {
- result.hi--;
- }
-
- return result;
-}
-
-
-/**************************************************************************
- m 6 4 A S L
-** 64 bit left shift
-**************************************************************************/
-DPUNS m64ASL( DPUNS x )
-{
- DPUNS result;
-
- result.hi = x.hi << 1;
- if (x.lo & CELL_HI_BIT)
- {
- result.hi++;
- }
-
- result.lo = x.lo << 1;
-
- return result;
-}
-
-
-/**************************************************************************
- m 6 4 A S R
-** 64 bit right shift (unsigned - no sign extend)
-**************************************************************************/
-DPUNS m64ASR( DPUNS x )
-{
- DPUNS result;
-
- result.lo = x.lo >> 1;
- if (x.hi & 1)
- {
- result.lo |= CELL_HI_BIT;
- }
-
- result.hi = x.hi >> 1;
- return result;
-}
-
-
-/**************************************************************************
- m 6 4 O r
-** 64 bit bitwise OR
-**************************************************************************/
-DPUNS m64Or( DPUNS x, DPUNS y )
-{
- DPUNS result;
-
- result.hi = x.hi | y.hi;
- result.lo = x.lo | y.lo;
-
- return result;
-}
-
-
-/**************************************************************************
- m 6 4 C o m p a r e
-** Return -1 if x < y; 0 if x==y, and 1 if x > y.
-**************************************************************************/
-int m64Compare(DPUNS x, DPUNS y)
-{
- int result;
-
- if (x.hi > y.hi)
- {
- result = +1;
- }
- else if (x.hi < y.hi)
- {
- result = -1;
- }
- else
- {
- /* High parts are equal */
- if (x.lo > y.lo)
- {
- result = +1;
- }
- else if (x.lo < y.lo)
- {
- result = -1;
- }
- else
- {
- result = 0;
- }
- }
-
- return result;
-}
-
-
-/**************************************************************************
- f i c l L o n g M u l
-** Portable versions of ficlLongMul and ficlLongDiv in C
-** Contributed by:
-** Michael A. Gauland gaulandm@mdhost.cse.tek.com
-**************************************************************************/
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS result = { 0, 0 };
- DPUNS addend;
-
- addend.lo = y;
- addend.hi = 0; /* No sign extension--arguments are unsigned */
-
- while (x != 0)
- {
- if ( x & 1)
- {
- result = m64Add(result, addend);
- }
- x >>= 1;
- addend = m64ASL(addend);
- }
- return result;
-}
-
-
-/**************************************************************************
- f i c l L o n g D i v
-** Portable versions of ficlLongMul and ficlLongDiv in C
-** Contributed by:
-** Michael A. Gauland gaulandm@mdhost.cse.tek.com
-**************************************************************************/
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- DPUNS quotient;
- DPUNS subtrahend;
- DPUNS mask;
-
- quotient.lo = 0;
- quotient.hi = 0;
-
- subtrahend.lo = y;
- subtrahend.hi = 0;
-
- mask.lo = 1;
- mask.hi = 0;
-
- while ((m64Compare(subtrahend, q) < 0) &&
- (subtrahend.hi & CELL_HI_BIT) == 0)
- {
- mask = m64ASL(mask);
- subtrahend = m64ASL(subtrahend);
- }
-
- while (mask.lo != 0 || mask.hi != 0)
- {
- if (m64Compare(subtrahend, q) <= 0)
- {
- q = m64Sub( q, subtrahend);
- quotient = m64Or(quotient, mask);
- }
- mask = m64ASR(mask);
- subtrahend = m64ASR(subtrahend);
- }
-
- result.quot = quotient.lo;
- result.rem = q.lo;
- return result;
-}
-
-#endif
-
diff --git a/math64.h b/math64.h
deleted file mode 100644
index 19e874107843..000000000000
--- a/math64.h
+++ /dev/null
@@ -1,86 +0,0 @@
-/*******************************************************************
-** m a t h 6 4 . h
-** 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 07:56:19-07 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
-** All rights reserved.
-**
-** 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
-** contact me by email at the address above.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** 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.
-*/
-
-#if !defined (__MATH64_H__)
-#define __MATH64_H__
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-DPINT m64Abs(DPINT x);
-int m64IsNegative(DPINT x);
-DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add);
-DPINT m64MulI(FICL_INT x, FICL_INT y);
-DPINT m64Negate(DPINT x);
-INTQR m64FlooredDivI(DPINT num, FICL_INT den);
-void i64Push(FICL_STACK *pStack, DPINT i64);
-DPINT i64Pop(FICL_STACK *pStack);
-void u64Push(FICL_STACK *pStack, DPUNS u64);
-DPUNS u64Pop(FICL_STACK *pStack);
-INTQR m64SymmetricDivI(DPINT num, FICL_INT den);
-UNS16 m64UMod(DPUNS *pUD, UNS16 base);
-
-
-#if PORTABLE_LONGMULDIV != 0 /* see sysdep.h */
-DPUNS m64Add(DPUNS x, DPUNS y);
-DPUNS m64ASL( DPUNS x );
-DPUNS m64ASR( DPUNS x );
-int m64Compare(DPUNS x, DPUNS y);
-DPUNS m64Or( DPUNS x, DPUNS y );
-DPUNS m64Sub(DPUNS x, DPUNS y);
-#endif
-
-#define i64Extend(i64) (i64).hi = ((i64).lo < 0) ? -1L : 0
-#define m64CastIU(i64) (*(DPUNS *)(&(i64)))
-#define m64CastUI(u64) (*(DPINT *)(&(u64)))
-#define m64CastQRIU(iqr) (*(UNSQR *)(&(iqr)))
-#define m64CastQRUI(uqr) (*(INTQR *)(&(uqr)))
-
-#define CELL_HI_BIT (1L << (BITS_PER_CELL-1))
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
-
diff --git a/prefix.c b/prefix.c
index ee3472a6ed46..40243ec90b93 100644
--- 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.5 2001-12-04 17:58:13-08 jsadler Exp jsadler $
+** $Id: prefix.c,v 1.8 2010/09/13 18:43:04 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -12,9 +12,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -44,7 +44,6 @@
#include <string.h>
#include <ctype.h>
#include "ficl.h"
-#include "math64.h"
/*
** (jws) revisions:
@@ -65,85 +64,67 @@ static char list_name[] = "<prefixes>";
/**************************************************************************
f i c l P a r s e P r e f i x
** This is the parse step for prefixes - it checks an incoming word
-** to see if it starts with a prefix, and if so runs the corrseponding
+** to see if it starts with a prefix, and if so runs the corresponding
** code against the remainder of the word and returns true.
**************************************************************************/
-int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si)
+int ficlVmParsePrefix(ficlVm *vm, ficlString s)
{
int i;
- FICL_HASH *pHash;
- FICL_WORD *pFW = ficlLookup(pVM->pSys, list_name);
+ ficlHash *hash;
+ ficlWord *word = ficlSystemLookup(vm->callback.system, list_name);
/*
** Make sure we found the prefix dictionary - otherwise silently fail
** If forth-wordlist is not in the search order, we won't find the prefixes.
*/
- if (!pFW)
- return FICL_FALSE;
+ if (!word)
+ return 0; /* false */
- pHash = (FICL_HASH *)(pFW->param[0].p);
+ hash = (ficlHash *)(word->param[0].p);
/*
** Walk the list looking for a match with the beginning of the incoming token
*/
- for (i = 0; i < (int)pHash->size; i++)
+ for (i = 0; i < (int)hash->size; i++)
{
- pFW = pHash->table[i];
- while (pFW != NULL)
+ word = hash->table[i];
+ while (word != NULL)
{
int n;
- n = pFW->nName;
+ n = word->length;
/*
** If we find a match, adjust the TIB to give back the non-prefix characters
** and execute the prefix word.
*/
- if (!strincmp(SI_PTR(si), pFW->name, (FICL_UNS)n))
+ if (!ficlStrincmp(FICL_STRING_GET_POINTER(s), word->name, (ficlUnsigned)n))
{
/* (sadler) fixed off-by-one error when the token has no trailing space in the TIB */
- vmSetTibIndex(pVM, si.cp + n - pVM->tib.cp );
- vmExecute(pVM, pFW);
+ ficlVmSetTibIndex(vm, s.text + n - vm->tib.text);
+ ficlVmExecuteWord(vm, word);
- return FICL_TRUE;
+ return 1; /* true */
}
- pFW = pFW->link;
+ word = word->link;
}
}
- return FICL_FALSE;
+ return 0; /* false */
}
-static void tempBase(FICL_VM *pVM, int base)
+static void ficlPrimitiveTempBase(ficlVm *vm)
{
- int oldbase = pVM->base;
- STRINGINFO si = vmGetWord0(pVM);
+ int oldbase = vm->base;
+ ficlString number = ficlVmGetWord0(vm);
+ int base = ficlStackPopInteger(vm->dataStack);
- pVM->base = base;
- if (!ficlParseNumber(pVM, si))
- {
- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not recognized", i, SI_PTR(si));
- }
+ vm->base = base;
+ if (!ficlVmParseNumber(vm, number))
+ ficlVmThrowError(vm, "%.*s not recognized", FICL_STRING_GET_LENGTH(number), FICL_STRING_GET_POINTER(number));
- pVM->base = oldbase;
+ vm->base = oldbase;
return;
}
-static void fTempBase(FICL_VM *pVM)
-{
- int base = stackPopINT(pVM->pStack);
- tempBase(pVM, base);
- return;
-}
-
-static void prefixHex(FICL_VM *pVM)
-{
- tempBase(pVM, 16);
-}
-
-static void prefixTen(FICL_VM *pVM)
-{
- tempBase(pVM, 10);
-}
/**************************************************************************
@@ -153,45 +134,45 @@ static void prefixTen(FICL_VM *pVM)
** If they need to generate code in compile state you must add
** this code explicitly.
**************************************************************************/
-void ficlCompilePrefix(FICL_SYSTEM *pSys)
+void ficlSystemCompilePrefix(ficlSystem *system)
{
- FICL_DICT *dp = pSys->dp;
- FICL_HASH *pHash;
- FICL_HASH *pPrevCompile = dp->pCompile;
-#if (FICL_EXTENDED_PREFIX)
- FICL_WORD *pFW;
-#endif
+ ficlDictionary *dictionary = system->dictionary;
+ ficlHash *hash;
/*
** Create a named wordlist for prefixes to reside in...
** Since we're doing a special kind of search, make it
** a single bucket hashtable - hashing does not help here.
*/
- pHash = dictCreateWordlist(dp, 1);
- pHash->name = list_name;
- dictAppendWord(dp, list_name, constantParen, FW_DEFAULT);
- dictAppendCell(dp, LVALUEtoCELL(pHash));
+ hash = ficlDictionaryCreateWordlist(dictionary, 1);
+ hash->name = list_name;
+ ficlDictionaryAppendConstantPointer(dictionary, list_name, hash);
- /*
- ** Put __tempbase in the forth-wordlist
- */
- dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT);
+ /*
+ ** Put __tempbase in the forth-wordlist
+ */
+ ficlDictionarySetPrimitive(dictionary, "__tempbase", ficlPrimitiveTempBase, FICL_WORD_DEFAULT);
/*
- ** Temporarily make the prefix list the compile wordlist so that
- ** we can create some precompiled prefixes.
+ ** If you want to add some prefixes at compilation-time, copy this line to the top of this function:
+ **
+ ficlHash *oldCompilationWordlist;
+
+ **
+ ** then copy this code to the bottom, just above the return:
+ **
+
+ oldCompilationWordlist = dictionary->compilationWordlist;
+ dictionary->compilationWordlist = hash;
+ ficlDictionarySetPrimitive(dictionary, YOUR WORD HERE, FICL_WORD_DEFAULT);
+ dictionary->compilationWordlist = oldCompilationWordlist;
+
+ **
+ ** and substitute in your own actual calls to ficlDictionarySetPrimitive() as needed.
+ **
+ ** Or--better yet--do it in your own code, so you don't have to re-modify the Ficl
+ ** source code every time we cut a new release!
*/
- dp->pCompile = pHash;
- dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT);
- dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT);
-#if (FICL_EXTENDED_PREFIX)
- pFW = ficlLookup(pSys, "\\");
- if (pFW)
- {
- dictAppendWord(dp, "//", pFW->code, FW_DEFAULT);
- }
-#endif
- dp->pCompile = pPrevCompile;
return;
}
diff --git a/primitives.c b/primitives.c
new file mode 100644
index 000000000000..00179cb2b1ff
--- /dev/null
+++ b/primitives.c
@@ -0,0 +1,3513 @@
+/*******************************************************************
+** w o r d s . c
+** Forth Inspired Command Language
+** ANS Forth CORE word-set written in C
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+** $Id: primitives.c,v 1.4 2010/09/13 18:43:04 asau Exp $
+*******************************************************************/
+/*
+** 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
+** 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 <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+
+
+/*
+** Control structure building words use these
+** strings' addresses as markers on the stack to
+** check for structure completion.
+*/
+static char doTag[] = "do";
+static char colonTag[] = "colon";
+static char leaveTag[] = "leave";
+
+static char destTag[] = "target";
+static char origTag[] = "origin";
+
+static char caseTag[] = "case";
+static char ofTag[] = "of";
+static char fallthroughTag[] = "fallthrough";
+
+/*
+** C O N T R O L S T R U C T U R E B U I L D E R S
+**
+** Push current dictionary location for later branch resolution.
+** The location may be either a branch target or a patch address...
+*/
+static void markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
+{
+ ficlStackPushPointer(vm->dataStack, dictionary->here);
+ ficlStackPushPointer(vm->dataStack, tag);
+ return;
+}
+
+static void markControlTag(ficlVm *vm, char *tag)
+{
+ ficlStackPushPointer(vm->dataStack, tag);
+ return;
+}
+
+static void matchControlTag(ficlVm *vm, char *wantTag)
+{
+ char *tag;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ tag = (char *)ficlStackPopPointer(vm->dataStack);
+ /*
+ ** Changed the code below to compare the pointers first (by popular demand)
+ */
+ if ( (tag != wantTag) && strcmp(tag, wantTag) )
+ {
+ ficlVmThrowError(vm, "Error -- unmatched control structure \"%s\"", wantTag);
+ }
+
+ return;
+}
+
+/*
+** Expect a branch target address on the param stack,
+** FICL_VM_STATE_COMPILE a literal offset from the current dictionary location
+** to the target address
+*/
+static void resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
+{
+ ficlInteger offset;
+ ficlCell *patchAddr;
+
+ matchControlTag(vm, tag);
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ offset = patchAddr - dictionary->here;
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(offset));
+
+ return;
+}
+
+
+/*
+** Expect a branch patch address on the param stack,
+** FICL_VM_STATE_COMPILE a literal offset from the patch location
+** to the current dictionary location
+*/
+static void resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag)
+{
+ ficlInteger offset;
+ ficlCell *patchAddr;
+
+ matchControlTag(vm, tag);
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ offset = dictionary->here - patchAddr;
+ *patchAddr = FICL_LVALUE_TO_CELL(offset);
+
+ return;
+}
+
+/*
+** Match the tag to the top of the stack. If success,
+** sopy "here" address into the ficlCell whose address is next
+** on the stack. Used by do..leave..loop.
+*/
+static void resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag)
+{
+ ficlCell *patchAddr;
+ char *tag;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ tag = ficlStackPopPointer(vm->dataStack);
+ /*
+ ** Changed the comparison below to compare the pointers first (by popular demand)
+ */
+ if ((tag != wantTag) && strcmp(tag, wantTag))
+ {
+ ficlVmTextOut(vm, "Warning -- Unmatched control word: ");
+ ficlVmTextOut(vm, wantTag);
+ ficlVmTextOut(vm, "\n");
+ }
+
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ *patchAddr = FICL_LVALUE_TO_CELL(dictionary->here);
+
+ return;
+}
+
+
+/**************************************************************************
+ c o l o n d e f i n i t i o n s
+** Code to begin compiling a colon definition
+** This function sets the state to FICL_VM_STATE_COMPILE, then creates a
+** new word whose name is the next word in the input stream
+** and whose code is colonParen.
+**************************************************************************/
+
+static void ficlPrimitiveColon(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ vm->state = FICL_VM_STATE_COMPILE;
+ markControlTag(vm, colonTag);
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionColonParen, FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
+#if FICL_WANT_LOCALS
+ vm->callback.system->localsCount = 0;
+#endif
+ return;
+}
+
+
+
+static void ficlPrimitiveSemicolonCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ matchControlTag(vm, colonTag);
+
+#if FICL_WANT_LOCALS
+ if (vm->callback.system->localsCount > 0)
+ {
+ ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
+ ficlDictionaryEmpty(locals, locals->forthWordlist->size);
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
+ }
+ vm->callback.system->localsCount = 0;
+#endif
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen);
+ vm->state = FICL_VM_STATE_INTERPRET;
+ ficlDictionaryUnsmudge(dictionary);
+ return;
+}
+
+
+/**************************************************************************
+ e x i t
+** CORE
+** This function simply pops the previous instruction
+** pointer and returns to the "next" loop. Used for exiting from within
+** a definition. Note that exitParen is identical to semiParen - they
+** are in two different functions so that "see" can correctly identify
+** the end of a colon definition, even if it uses "exit".
+**************************************************************************/
+
+static void ficlPrimitiveExitCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ FICL_IGNORE(vm);
+
+#if FICL_WANT_LOCALS
+ if (vm->callback.system->localsCount > 0)
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
+ }
+#endif
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen);
+ return;
+}
+
+
+/**************************************************************************
+ c o n s t a n t
+** IMMEDIATE
+** Compiles a constant into the dictionary. Constants return their
+** value when invoked. Expects a value on top of the parm stack.
+**************************************************************************/
+
+static void ficlPrimitiveConstant(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ ficlDictionaryAppendConstantInstruction(dictionary, name, ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack));
+ return;
+}
+
+
+static void ficlPrimitive2Constant(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ ficlDictionaryAppend2ConstantInstruction(dictionary, name, ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack));
+ return;
+}
+
+
+/**************************************************************************
+ d i s p l a y C e l l
+** Drop and print the contents of the ficlCell at the top of the param
+** stack
+**************************************************************************/
+
+static void ficlPrimitiveDot(ficlVm *vm)
+{
+ ficlCell c;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ c = ficlStackPop(vm->dataStack);
+ ficlLtoa((c).i, vm->pad, vm->base);
+ strcat(vm->pad, " ");
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+static void ficlPrimitiveUDot(ficlVm *vm)
+{
+ ficlUnsigned u;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ u = ficlStackPopUnsigned(vm->dataStack);
+ ficlUltoa(u, vm->pad, vm->base);
+ strcat(vm->pad, " ");
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+
+static void ficlPrimitiveHexDot(ficlVm *vm)
+{
+ ficlUnsigned u;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ u = ficlStackPopUnsigned(vm->dataStack);
+ ficlUltoa(u, vm->pad, 16);
+ strcat(vm->pad, " ");
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+
+/**************************************************************************
+ s t r l e n
+** Ficl ( c-string -- length )
+**
+** Returns the length of a C-style (zero-terminated) string.
+**
+** --lch
+**/
+static void ficlPrimitiveStrlen(ficlVm *vm)
+ {
+ char *address = (char *)ficlStackPopPointer(vm->dataStack);
+ ficlStackPushInteger(vm->dataStack, 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 ficlCell 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 (FICL_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 ficlPrimitiveSprintf(ficlVm *vm) /* */
+{
+ int bufferLength = ficlStackPopInteger(vm->dataStack);
+ char *buffer = (char *)ficlStackPopPointer(vm->dataStack);
+ char *bufferStart = buffer;
+
+ int formatLength = ficlStackPopInteger(vm->dataStack);
+ char *format = (char *)ficlStackPopPointer(vm->dataStack);
+ char *formatStop = format + formatLength;
+
+ int base = 10;
+ int unsignedInteger = 0; /* false */
+
+ int append = 1; /* 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((unsigned char)*format);
+ if (desiredLength)
+ {
+ desiredLength = strtoul(format, &format, 10);
+ if (format == formatStop)
+ break;
+ }
+ else if (*format == '*')
+ {
+ desiredLength = ficlStackPopInteger(vm->dataStack);
+ format++;
+ if (format == formatStop)
+ break;
+ }
+
+
+ switch (*format)
+ {
+ case 's':
+ case 'S':
+ {
+ actualLength = ficlStackPopInteger(vm->dataStack);
+ source = (char *)ficlStackPopPointer(vm->dataStack);
+ break;
+ }
+ case 'x':
+ case 'X':
+ base = 16;
+ case 'u':
+ case 'U':
+ unsignedInteger = 1; /* true */
+ case 'd':
+ case 'D':
+ {
+ int integer = ficlStackPopInteger(vm->dataStack);
+ if (unsignedInteger)
+ ficlUltoa(integer, scratch, base);
+ else
+ ficlLtoa(integer, scratch, base);
+ base = 10;
+ unsignedInteger = 0; /* false */
+ source = scratch;
+ actualLength = strlen(scratch);
+ break;
+ }
+ case '%':
+ source = format;
+ actualLength = 1;
+ default:
+ continue;
+ }
+ }
+
+ if (append)
+ {
+ if (!desiredLength)
+ desiredLength = actualLength;
+ if (desiredLength > bufferLength)
+ {
+ append = 0; /* false */
+ desiredLength = bufferLength;
+ }
+ while (desiredLength > actualLength)
+ {
+ *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
+ bufferLength--;
+ desiredLength--;
+ }
+ memcpy(buffer, source, actualLength);
+ buffer += actualLength;
+ bufferLength -= actualLength;
+ }
+
+ format++;
+ }
+
+ ficlStackPushPointer(vm->dataStack, bufferStart);
+ ficlStackPushInteger(vm->dataStack, buffer - bufferStart);
+ ficlStackPushInteger(vm->dataStack, append && FICL_TRUE);
+}
+
+
+/**************************************************************************
+ d u p & f r i e n d s
+**
+**************************************************************************/
+
+static void ficlPrimitiveDepth(ficlVm *vm)
+{
+ int i;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ i = ficlStackDepth(vm->dataStack);
+ ficlStackPushInteger(vm->dataStack, i);
+ return;
+}
+
+
+/**************************************************************************
+ e m i t & f r i e n d s
+**
+**************************************************************************/
+
+static void ficlPrimitiveEmit(ficlVm *vm)
+{
+ char *buffer = vm->pad;
+ int i;
+
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ i = ficlStackPopInteger(vm->dataStack);
+ buffer[0] = (char)i;
+ buffer[1] = '\0';
+ ficlVmTextOut(vm, buffer);
+ return;
+}
+
+
+static void ficlPrimitiveCR(ficlVm *vm)
+{
+ ficlVmTextOut(vm, "\n");
+ return;
+}
+
+
+static void ficlPrimitiveBackslash(ficlVm *vm)
+{
+ char *trace = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ char c = *trace;
+
+ while ((trace != stop) && (c != '\r') && (c != '\n'))
+ {
+ c = *++trace;
+ }
+
+ /*
+ ** Cope with DOS or UNIX-style EOLs -
+ ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
+ ** and point trace to next char. If EOL is \0, we're done.
+ */
+ if (trace != stop)
+ {
+ trace++;
+
+ if ( (trace != stop) && (c != *trace)
+ && ((*trace == '\r') || (*trace == '\n')) )
+ trace++;
+ }
+
+ ficlVmUpdateTib(vm, trace);
+ return;
+}
+
+
+/*
+** paren CORE
+** Compilation: Perform the execution semantics given below.
+** Execution: ( "ccc<paren>" -- )
+** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
+** The number of characters in ccc may be zero to the number of characters
+** in the parse area.
+**
+*/
+static void ficlPrimitiveParenthesis(ficlVm *vm)
+{
+ ficlVmParseStringEx(vm, ')', 0);
+ return;
+}
+
+
+/**************************************************************************
+ F E T C H & S T O R E
+**
+**************************************************************************/
+
+/**************************************************************************
+ 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.
+**************************************************************************/
+
+static void ficlPrimitiveIfCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
+ markBranch(dictionary, vm, origTag);
+ ficlDictionaryAppendUnsigned(dictionary, 1);
+ return;
+}
+
+
+
+
+/**************************************************************************
+ e l s e C o I m
+**
+** IMMEDIATE -- compiles an "else"...
+** 1) FICL_VM_STATE_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
+** 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE address.
+** 4) Push the "else" patch address. ("endif" patches this to jump past
+** the "else" code.
+**************************************************************************/
+
+static void ficlPrimitiveElseCoIm(ficlVm *vm)
+{
+ ficlCell *patchAddr;
+ ficlInteger offset;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ /* (1) FICL_VM_STATE_COMPILE branch runtime */
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
+ matchControlTag(vm, origTag);
+ patchAddr =
+ (ficlCell *)ficlStackPopPointer(vm->dataStack); /* (2) pop "if" patch addr */
+ markBranch(dictionary, vm, origTag); /* (4) push "else" patch addr */
+ ficlDictionaryAppendUnsigned(dictionary, 1); /* (1) FICL_VM_STATE_COMPILE patch placeholder */
+ offset = dictionary->here - patchAddr;
+ *patchAddr = FICL_LVALUE_TO_CELL(offset); /* (3) Patch "if" */
+
+ return;
+}
+
+
+/**************************************************************************
+ e n d i f C o I m
+**
+**************************************************************************/
+
+static void ficlPrimitiveEndifCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ resolveForwardBranch(dictionary, vm, origTag);
+ return;
+}
+
+
+/**************************************************************************
+ c a s e C o I m
+** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
+**
+**
+** At FICL_VM_STATE_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 ficlPrimitiveCaseCoIm(ficlVm *vm)
+{
+ FICL_STACK_CHECK(vm->dataStack, 0, 2);
+
+ ficlStackPushUnsigned(vm->dataStack, 0);
+ markControlTag(vm, caseTag);
+ return;
+}
+
+
+/**************************************************************************
+ e n d c a s eC o I m
+** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
+**************************************************************************/
+
+static void ficlPrimitiveEndcaseCoIm(ficlVm *vm)
+{
+ ficlUnsigned fixupCount;
+ ficlDictionary *dictionary;
+ ficlCell *patchAddr;
+ ficlInteger offset;
+
+ /*
+ ** if the last OF ended with FALLTHROUGH,
+ ** just add the FALLTHROUGH fixup to the
+ ** ENDOF fixups
+ */
+ if (ficlStackGetTop(vm->dataStack).p == fallthroughTag)
+ {
+ matchControlTag(vm, fallthroughTag);
+ patchAddr = ficlStackPopPointer(vm->dataStack);
+ matchControlTag(vm, caseTag);
+ fixupCount = ficlStackPopUnsigned(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, patchAddr);
+ ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
+ markControlTag(vm, caseTag);
+ }
+
+ matchControlTag(vm, caseTag);
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ fixupCount = ficlStackPopUnsigned(vm->dataStack);
+ FICL_STACK_CHECK(vm->dataStack, fixupCount, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop);
+
+ while (fixupCount--)
+ {
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ offset = dictionary->here - patchAddr;
+ *patchAddr = FICL_LVALUE_TO_CELL(offset);
+ }
+ return;
+}
+
+
+/**************************************************************************
+ o f C o I m
+** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
+**************************************************************************/
+
+static void ficlPrimitiveOfCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlCell *fallthroughFixup = NULL;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 3);
+
+ if (ficlStackGetTop(vm->dataStack).p == fallthroughTag)
+ {
+ matchControlTag(vm, fallthroughTag);
+ fallthroughFixup = ficlStackPopPointer(vm->dataStack);
+ }
+
+ matchControlTag(vm, caseTag);
+
+ markControlTag(vm, caseTag);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen);
+ markBranch(dictionary, vm, ofTag);
+ ficlDictionaryAppendUnsigned(dictionary, 2);
+
+ if (fallthroughFixup != NULL)
+ {
+ ficlInteger offset = dictionary->here - fallthroughFixup;
+ *fallthroughFixup = FICL_LVALUE_TO_CELL(offset);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ e n d o f C o I m
+** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
+**************************************************************************/
+
+static void ficlPrimitiveEndofCoIm(ficlVm *vm)
+{
+ ficlCell *patchAddr;
+ ficlUnsigned fixupCount;
+ ficlInteger offset;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 4, 3);
+
+ /* ensure we're in an OF, */
+ matchControlTag(vm, ofTag);
+ /* grab the address of the branch location after the OF */
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ /* ensure we're also in a "case" */
+ matchControlTag(vm, caseTag);
+ /* grab the current number of ENDOF fixups */
+ fixupCount = ficlStackPopUnsigned(vm->dataStack);
+
+ /* FICL_VM_STATE_COMPILE branch runtime */
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
+
+ /* push a new ENDOF fixup, the updated count of ENDOF fixups, and the caseTag */
+ ficlStackPushPointer(vm->dataStack, dictionary->here);
+ ficlStackPushUnsigned(vm->dataStack, fixupCount + 1);
+ markControlTag(vm, caseTag);
+
+ /* reserve space for the ENDOF fixup */
+ ficlDictionaryAppendUnsigned(dictionary, 2);
+
+ /* and patch the original OF */
+ offset = dictionary->here - patchAddr;
+ *patchAddr = FICL_LVALUE_TO_CELL(offset);
+}
+
+/**************************************************************************
+ f a l l t h r o u g h C o I m
+** IMMEDIATE FICL_VM_STATE_COMPILE-ONLY
+**************************************************************************/
+
+static void ficlPrimitiveFallthroughCoIm(ficlVm *vm)
+{
+ ficlCell *patchAddr;
+ ficlInteger offset;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 4, 3);
+
+ /* ensure we're in an OF, */
+ matchControlTag(vm, ofTag);
+ /* grab the address of the branch location after the OF */
+ patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack);
+ /* ensure we're also in a "case" */
+ matchControlTag(vm, caseTag);
+
+ /* okay, here we go. put the case tag back. */
+ markControlTag(vm, caseTag);
+
+ /* FICL_VM_STATE_COMPILE branch runtime */
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
+
+ /* push a new FALLTHROUGH fixup and the fallthroughTag */
+ ficlStackPushPointer(vm->dataStack, dictionary->here);
+ markControlTag(vm, fallthroughTag);
+
+ /* reserve space for the FALLTHROUGH fixup */
+ ficlDictionaryAppendUnsigned(dictionary, 2);
+
+ /* and patch the original OF */
+ offset = dictionary->here - patchAddr;
+ *patchAddr = FICL_LVALUE_TO_CELL(offset);
+}
+
+/**************************************************************************
+ h a s h
+** hash ( c-addr u -- code)
+** calculates hashcode of specified string and leaves it on the stack
+**************************************************************************/
+
+static void ficlPrimitiveHash(ficlVm *vm)
+{
+ ficlString s;
+ FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack));
+ FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
+ ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s));
+ return;
+}
+
+
+/**************************************************************************
+ i n t e r p r e t
+** This is the "user interface" of a Forth. It does the following:
+** while there are words in the VM's Text Input Buffer
+** Copy next word into the pad (ficlVmGetWord)
+** Attempt to find the word in the dictionary (ficlDictionaryLookup)
+** If successful, execute the word.
+** Otherwise, attempt to convert the word to a number (isNumber)
+** If successful, push the number onto the parameter stack.
+** Otherwise, print an error message and exit loop...
+** End Loop
+**
+** From the standard, section 3.4
+** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
+** repeat the following steps until either the parse area is empty or an
+** ambiguous condition exists:
+** a) Skip leading spaces and parse a name (see 3.4.1);
+**************************************************************************/
+
+static void ficlPrimitiveInterpret(ficlVm *vm)
+{
+ ficlString s;
+ int i;
+ ficlSystem *system;
+
+ FICL_VM_ASSERT(vm, vm);
+
+ system = vm->callback.system;
+ s = ficlVmGetWord0(vm);
+
+ /*
+ ** Get next word...if out of text, we're done.
+ */
+ if (s.length == 0)
+ {
+ ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT);
+ }
+
+ /*
+ ** Run the parse chain against the incoming token until somebody eats it.
+ ** Otherwise emit an error message and give up.
+ */
+ for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
+ {
+ ficlWord *word = system->parseList[i];
+
+ if (word == NULL)
+ break;
+
+ if (word->code == ficlPrimitiveParseStepParen)
+ {
+ ficlParseStep pStep;
+ pStep = (ficlParseStep)(word->param->fn);
+ if ((*pStep)(vm, s))
+ return;
+ }
+ else
+ {
+ ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
+ ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
+ ficlVmExecuteXT(vm, word);
+ if (ficlStackPopInteger(vm->dataStack))
+ return;
+ }
+ }
+
+ ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s), FICL_STRING_GET_POINTER(s));
+
+ return; /* back to inner interpreter */
+}
+
+
+/*
+** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
+** FICL_VM_STATE_INTERPRET)
+*/
+static void ficlPrimitiveLookup(ficlVm *vm)
+{
+ ficlString name;
+ FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
+ FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack));
+ ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name));
+ return;
+}
+
+
+/**************************************************************************
+ p a r e n P a r s e S t e p
+** (parse-step) ( c-addr u -- flag )
+** runtime for a precompiled parse step - pop a counted string off the
+** stack, run the parse step against it, and push the result flag (FICL_TRUE
+** if success, FICL_FALSE otherwise).
+**************************************************************************/
+
+void ficlPrimitiveParseStepParen(ficlVm *vm)
+{
+ ficlString s;
+ ficlWord *word = vm->runningWord;
+ ficlParseStep pStep = (ficlParseStep)(word->param->fn);
+
+ FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack));
+ FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack));
+
+ ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s));
+
+ return;
+}
+
+
+static void ficlPrimitiveAddParseStep(ficlVm *vm)
+{
+ ficlWord *pStep;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p);
+ if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep))
+ ficlSystemAddParseStep(vm->callback.system, pStep);
+ return;
+}
+
+
+
+/**************************************************************************
+ l i t e r a l I m
+**
+** IMMEDIATE code for "literal". This function gets a value from the stack
+** and compiles it into the dictionary preceded by the code for "(literal)".
+** IMMEDIATE
+**************************************************************************/
+
+void ficlPrimitiveLiteralIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlInteger value;
+
+ value = ficlStackPopInteger(vm->dataStack);
+
+ switch (value)
+ {
+ case 1:
+ case 2:
+ case 3:
+ case 4:
+ case 5:
+ case 6:
+ case 7:
+ case 8:
+ case 9:
+ case 10:
+ case 11:
+ case 12:
+ case 13:
+ case 14:
+ case 15:
+ case 16:
+ ficlDictionaryAppendUnsigned(dictionary, value);
+ break;
+
+ case 0:
+ case -1:
+ case -2:
+ case -3:
+ case -4:
+ case -5:
+ case -6:
+ case -7:
+ case -8:
+ case -9:
+ case -10:
+ case -11:
+ case -12:
+ case -13:
+ case -14:
+ case -15:
+ case -16:
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstruction0- value);
+ break;
+
+ default:
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLiteralParen);
+ ficlDictionaryAppendUnsigned(dictionary, value);
+ break;
+ }
+
+ return;
+}
+
+
+static void ficlPrimitive2LiteralIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen);
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
+
+ return;
+}
+
+/**************************************************************************
+ D o / L o o p
+** do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
+** Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do),
+** allot space to hold the "leave" address, push a branch
+** target address for the loop.
+** (do) -- runtime for "do"
+** pops index and limit from the p stack and moves them
+** to the r stack, then skips to the loop body.
+** loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY
+** +loop
+** Compiles code for the test part of a loop:
+** FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and
+** copy "here" address to the "leave" address allotted by "do"
+** i,j,k -- FICL_VM_STATE_COMPILE ONLY
+** Runtime: Push loop indices on param stack (i is innermost loop...)
+** Note: each loop has three values on the return stack:
+** ( R: leave limit index )
+** "leave" is the absolute address of the next ficlCell after the loop
+** limit and index are the loop control variables.
+** leave -- FICL_VM_STATE_COMPILE ONLY
+** Runtime: pop the loop control variables, then pop the
+** "leave" address and jump (absolute) there.
+**************************************************************************/
+
+static void ficlPrimitiveDoCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen);
+ /*
+ ** Allot space for a pointer to the end
+ ** of the loop - "leave" uses this...
+ */
+ markBranch(dictionary, vm, leaveTag);
+ ficlDictionaryAppendUnsigned(dictionary, 0);
+ /*
+ ** Mark location of head of loop...
+ */
+ markBranch(dictionary, vm, doTag);
+
+ return;
+}
+
+
+static void ficlPrimitiveQDoCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen);
+ /*
+ ** Allot space for a pointer to the end
+ ** of the loop - "leave" uses this...
+ */
+ markBranch(dictionary, vm, leaveTag);
+ ficlDictionaryAppendUnsigned(dictionary, 0);
+ /*
+ ** Mark location of head of loop...
+ */
+ markBranch(dictionary, vm, doTag);
+
+ return;
+}
+
+
+static void ficlPrimitiveLoopCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen);
+ resolveBackBranch(dictionary, vm, doTag);
+ resolveAbsBranch(dictionary, vm, leaveTag);
+ return;
+}
+
+
+static void ficlPrimitivePlusLoopCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen);
+ resolveBackBranch(dictionary, vm, doTag);
+ resolveAbsBranch(dictionary, vm, leaveTag);
+ return;
+}
+
+
+
+/**************************************************************************
+ v a r i a b l e
+**
+**************************************************************************/
+
+static void ficlPrimitiveVariable(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
+ ficlVmDictionaryAllotCells(vm, dictionary, 1);
+ return;
+}
+
+
+static void ficlPrimitive2Variable(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT);
+ ficlVmDictionaryAllotCells(vm, dictionary, 2);
+ return;
+}
+
+
+/**************************************************************************
+ b a s e & f r i e n d s
+**
+**************************************************************************/
+
+static void ficlPrimitiveBase(ficlVm *vm)
+{
+ ficlCell *pBase;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ pBase = (ficlCell *)(&vm->base);
+ ficlStackPush(vm->dataStack, FICL_LVALUE_TO_CELL(pBase));
+ return;
+}
+
+
+static void ficlPrimitiveDecimal(ficlVm *vm)
+{
+ vm->base = 10;
+ return;
+}
+
+
+static void ficlPrimitiveHex(ficlVm *vm)
+{
+ vm->base = 16;
+ return;
+}
+
+
+/**************************************************************************
+ a l l o t & f r i e n d s
+**
+**************************************************************************/
+
+static void ficlPrimitiveAllot(ficlVm *vm)
+{
+ ficlDictionary *dictionary;
+ ficlInteger i;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ i = ficlStackPopInteger(vm->dataStack);
+
+ FICL_VM_DICTIONARY_CHECK(vm, dictionary, i);
+
+ ficlVmDictionaryAllot(vm, dictionary, i);
+ return;
+}
+
+
+static void ficlPrimitiveHere(ficlVm *vm)
+{
+ ficlDictionary *dictionary;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ dictionary = ficlVmGetDictionary(vm);
+ ficlStackPushPointer(vm->dataStack, dictionary->here);
+ return;
+}
+
+
+
+
+/**************************************************************************
+ t i c k
+** tick CORE ( "<spaces>name" -- xt )
+** Skip leading space delimiters. Parse name delimited by a space. Find
+** name and return xt, the execution token for name. An ambiguous condition
+** exists if name is not found.
+**************************************************************************/
+void ficlPrimitiveTick(ficlVm *vm)
+{
+ ficlWord *word = NULL;
+ ficlString name = ficlVmGetWord(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
+ if (!word)
+ ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
+ ficlStackPushPointer(vm->dataStack, word);
+ return;
+}
+
+
+static void ficlPrimitiveBracketTickCoIm(ficlVm *vm)
+{
+ ficlPrimitiveTick(vm);
+ ficlPrimitiveLiteralIm(vm);
+
+ return;
+}
+
+
+/**************************************************************************
+ p o s t p o n e
+** Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to
+** insert it into definitions created by the resulting word
+** (defers compilation, even of immediate words)
+**************************************************************************/
+
+static void ficlPrimitivePostponeCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *word;
+ ficlWord *pComma = ficlSystemLookup(vm->callback.system, ",");
+ FICL_VM_ASSERT(vm, pComma);
+
+ ficlPrimitiveTick(vm);
+ word = ficlStackGetTop(vm->dataStack).p;
+ if (ficlWordIsImmediate(word))
+ {
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack));
+ }
+ else
+ {
+ ficlPrimitiveLiteralIm(vm);
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(pComma));
+ }
+
+ return;
+}
+
+
+
+/**************************************************************************
+ e x e c u t e
+** Pop an execution token (pointer to a word) off the stack and
+** run it
+**************************************************************************/
+
+static void ficlPrimitiveExecute(ficlVm *vm)
+{
+ ficlWord *word;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ word = ficlStackPopPointer(vm->dataStack);
+ ficlVmExecuteWord(vm, word);
+
+ return;
+}
+
+
+/**************************************************************************
+ i m m e d i a t e
+** Make the most recently compiled word IMMEDIATE -- it executes even
+** in FICL_VM_STATE_COMPILE state (most often used for control compiling words
+** such as IF, THEN, etc)
+**************************************************************************/
+
+static void ficlPrimitiveImmediate(ficlVm *vm)
+{
+ FICL_IGNORE(vm);
+ ficlDictionarySetImmediate(ficlVmGetDictionary(vm));
+ return;
+}
+
+
+static void ficlPrimitiveCompileOnly(ficlVm *vm)
+{
+ FICL_IGNORE(vm);
+ ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY);
+ return;
+}
+
+
+static void ficlPrimitiveSetObjectFlag(ficlVm *vm)
+{
+ FICL_IGNORE(vm);
+ ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT);
+ return;
+}
+
+static void ficlPrimitiveIsObject(ficlVm *vm)
+{
+ int flag;
+ ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
+
+ flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT)) ? FICL_TRUE : FICL_FALSE;
+ ficlStackPushInteger(vm->dataStack, flag);
+ return;
+}
+
+
+
+static void ficlPrimitiveCountedStringQuoteIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {
+ ficlCountedString *counted = (ficlCountedString *) dictionary->here;
+ ficlVmGetString(vm, counted, '\"');
+ ficlStackPushPointer(vm->dataStack, counted);
+ /* move HERE past string so it doesn't get overwritten. --lch */
+ ficlVmDictionaryAllot(vm, dictionary, counted->length + sizeof(ficlUnsigned8));
+ }
+ else /* FICL_VM_STATE_COMPILE state */
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionCStringLiteralParen);
+ dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
+ ficlDictionaryAlign(dictionary);
+ }
+
+ return;
+}
+
+/**************************************************************************
+ d o t Q u o t e
+** IMMEDIATE word that compiles a string literal for later display
+** FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the string from the
+** TIB to the dictionary. Backpatch the count byte and align the dictionary.
+**************************************************************************/
+
+static void ficlPrimitiveDotQuoteCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *pType = ficlSystemLookup(vm->callback.system, "type");
+ FICL_VM_ASSERT(vm, pType);
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
+ dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
+ ficlDictionaryAlign(dictionary);
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(pType));
+ return;
+}
+
+
+static void ficlPrimitiveDotParen(ficlVm *vm)
+{
+ char *from = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ char *to = vm->pad;
+ char c;
+
+ /*
+ ** Note: the standard does not want leading spaces skipped.
+ */
+ for (c = *from; (from != stop) && (c != ')'); c = *++from)
+ *to++ = c;
+
+ *to = '\0';
+ if ((from != stop) && (c == ')'))
+ from++;
+
+ ficlVmTextOut(vm, vm->pad);
+ ficlVmUpdateTib(vm, from);
+
+ return;
+}
+
+
+/**************************************************************************
+ s l i t e r a l
+** STRING
+** Interpretation: Interpretation semantics for this word are undefined.
+** Compilation: ( c-addr1 u -- )
+** Append the run-time semantics given below to the current definition.
+** Run-time: ( -- c-addr2 u )
+** Return c-addr2 u describing a string consisting of the characters
+** specified by c-addr1 u during compilation. A program shall not alter
+** the returned string.
+**************************************************************************/
+static void ficlPrimitiveSLiteralCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary;
+ char *from;
+ char *to;
+ ficlUnsigned length;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ length = ficlStackPopUnsigned(vm->dataStack);
+ from = ficlStackPopPointer(vm->dataStack);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
+ to = (char *) dictionary->here;
+ *to++ = (char) length;
+
+ for (; length > 0; --length)
+ {
+ *to++ = *from++;
+ }
+
+ *to++ = 0;
+ dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to));
+ return;
+}
+
+
+/**************************************************************************
+ s t a t e
+** Return the address of the VM's state member (must be sized the
+** same as a ficlCell for this reason)
+**************************************************************************/
+static void ficlPrimitiveState(ficlVm *vm)
+{
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+ ficlStackPushPointer(vm->dataStack, &vm->state);
+ return;
+}
+
+
+/**************************************************************************
+ c r e a t e . . . d o e s >
+** Make a new word in the dictionary with the run-time effect of
+** a variable (push my address), but with extra space allotted
+** for use by does> .
+**************************************************************************/
+
+
+static void ficlPrimitiveCreate(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT);
+ ficlVmDictionaryAllotCells(vm, dictionary, 1);
+ return;
+}
+
+
+static void ficlPrimitiveDoesCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+#if FICL_WANT_LOCALS
+ if (vm->callback.system->localsCount > 0)
+ {
+ ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
+ ficlDictionaryEmpty(locals, locals->forthWordlist->size);
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionUnlinkParen);
+ }
+
+ vm->callback.system->localsCount = 0;
+#endif
+ FICL_IGNORE(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen);
+ return;
+}
+
+
+/**************************************************************************
+ t o b o d y
+** to-body CORE ( xt -- a-addr )
+** a-addr is the data-field address corresponding to xt. An ambiguous
+** condition exists if xt is not for a word defined via CREATE.
+**************************************************************************/
+static void ficlPrimitiveToBody(ficlVm *vm)
+{
+ ficlWord *word;
+ FICL_STACK_CHECK(vm->dataStack, 1, 1);
+
+ word = ficlStackPopPointer(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, word->param + 1);
+ return;
+}
+
+
+/*
+** from-body Ficl ( a-addr -- xt )
+** Reverse effect of >body
+*/
+static void ficlPrimitiveFromBody(ficlVm *vm)
+{
+ char *ptr;
+ FICL_STACK_CHECK(vm->dataStack, 1, 1);
+
+ ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord);
+ ficlStackPushPointer(vm->dataStack, ptr);
+ return;
+}
+
+
+/*
+** >name Ficl ( xt -- c-addr u )
+** Push the address and length of a word's name given its address
+** xt.
+*/
+static void ficlPrimitiveToName(ficlVm *vm)
+{
+ ficlWord *word;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 2);
+
+ word = ficlStackPopPointer(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, word->name);
+ ficlStackPushUnsigned(vm->dataStack, word->length);
+ return;
+}
+
+
+static void ficlPrimitiveLastWord(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *wp = dictionary->smudge;
+ FICL_VM_ASSERT(vm, wp);
+ ficlVmPush(vm, FICL_LVALUE_TO_CELL(wp));
+ return;
+}
+
+
+/**************************************************************************
+ l b r a c k e t e t c
+**
+**************************************************************************/
+
+static void ficlPrimitiveLeftBracketCoIm(ficlVm *vm)
+{
+ vm->state = FICL_VM_STATE_INTERPRET;
+ return;
+}
+
+
+static void ficlPrimitiveRightBracket(ficlVm *vm)
+{
+ vm->state = FICL_VM_STATE_COMPILE;
+ return;
+}
+
+
+/**************************************************************************
+ p i c t u r e d n u m e r i c w o r d s
+**
+** less-number-sign CORE ( -- )
+** Initialize the pictured numeric output conversion process.
+** (clear the pad)
+**************************************************************************/
+static void ficlPrimitiveLessNumberSign(ficlVm *vm)
+{
+ ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ counted->length = 0;
+ return;
+}
+
+/*
+** number-sign CORE ( ud1 -- ud2 )
+** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
+** n. (n is the least-significant digit of ud1.) Convert n to external form
+** and add the resulting character to the beginning of the pictured numeric
+** output string. An ambiguous condition exists if # executes outside of a
+** <# #> delimited number conversion.
+*/
+static void ficlPrimitiveNumberSign(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ ficl2Unsigned u;
+ ficl2UnsignedQR uqr;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+ counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ u = ficlStackPop2Unsigned(vm->dataStack);
+ uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
+ counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
+ ficlStackPush2Unsigned(vm->dataStack, uqr.quotient);
+ return;
+}
+
+/*
+** number-sign-greater CORE ( xd -- c-addr u )
+** Drop xd. Make the pictured numeric output string available as a character
+** string. c-addr and u specify the resulting character string. A program
+** may replace characters within the string.
+*/
+static void ficlPrimitiveNumberSignGreater(ficlVm *vm)
+{
+ ficlCountedString *counted;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+ counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ counted->text[counted->length] = 0;
+ ficlStringReverse(counted->text);
+ ficlStackDrop(vm->dataStack, 2);
+ ficlStackPushPointer(vm->dataStack, counted->text);
+ ficlStackPushUnsigned(vm->dataStack, counted->length);
+ return;
+}
+
+/*
+** number-sign-s CORE ( ud1 -- ud2 )
+** Convert one digit of ud1 according to the rule for #. Continue conversion
+** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
+** #S executes outside of a <# #> delimited number conversion.
+** TO DO: presently does not use ud1 hi ficlCell - use it!
+*/
+static void ficlPrimitiveNumberSignS(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ ficl2Unsigned u;
+ ficl2UnsignedQR uqr;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+ counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ u = ficlStackPop2Unsigned(vm->dataStack);
+
+ do
+ {
+ uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base));
+ counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder);
+ u = uqr.quotient;
+ }
+ while (FICL_2UNSIGNED_NOT_ZERO(u));
+
+ ficlStackPush2Unsigned(vm->dataStack, u);
+ return;
+}
+
+/*
+** HOLD CORE ( char -- )
+** Add char to the beginning of the pictured numeric output string. An ambiguous
+** condition exists if HOLD executes outside of a <# #> delimited number conversion.
+*/
+static void ficlPrimitiveHold(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ int i;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ i = ficlStackPopInteger(vm->dataStack);
+ counted->text[counted->length++] = (char) i;
+ return;
+}
+
+/*
+** SIGN CORE ( n -- )
+** If n is negative, add a minus sign to the beginning of the pictured
+** numeric output string. An ambiguous condition exists if SIGN
+** executes outside of a <# #> delimited number conversion.
+*/
+static void ficlPrimitiveSign(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ int i;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad);
+ i = ficlStackPopInteger(vm->dataStack);
+ if (i < 0)
+ counted->text[counted->length++] = '-';
+ return;
+}
+
+
+/**************************************************************************
+ t o N u m b e r
+** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
+** ud2 is the unsigned result of converting the characters within the
+** string specified by c-addr1 u1 into digits, using the number in BASE,
+** and adding each into ud1 after multiplying ud1 by the number in BASE.
+** Conversion continues left-to-right until a character that is not
+** convertible, including any + or -, is encountered or the string is
+** entirely converted. c-addr2 is the location of the first unconverted
+** character or the first character past the end of the string if the string
+** was entirely converted. u2 is the number of unconverted characters in the
+** string. An ambiguous condition exists if ud2 overflows during the
+** conversion.
+**************************************************************************/
+static void ficlPrimitiveToNumber(ficlVm *vm)
+{
+ ficlUnsigned length;
+ char *trace;
+ ficl2Unsigned accumulator;
+ ficlUnsigned base = vm->base;
+ ficlUnsigned c;
+ ficlUnsigned digit;
+
+ FICL_STACK_CHECK(vm->dataStack,4,4);
+
+ length = ficlStackPopUnsigned(vm->dataStack);
+ trace = (char *)ficlStackPopPointer(vm->dataStack);
+ accumulator = ficlStackPop2Unsigned(vm->dataStack);
+
+ for (c = *trace; length > 0; c = *++trace, length--)
+ {
+ if (c < '0')
+ break;
+
+ digit = c - '0';
+
+ if (digit > 9)
+ digit = tolower(c) - 'a' + 10;
+ /*
+ ** Note: following test also catches chars between 9 and a
+ ** because 'digit' is unsigned!
+ */
+ if (digit >= base)
+ break;
+
+ accumulator = ficl2UnsignedMultiplyAccumulate(accumulator, base, digit);
+ }
+
+ ficlStackPush2Unsigned(vm->dataStack, accumulator);
+ ficlStackPushPointer(vm->dataStack, trace);
+ ficlStackPushUnsigned(vm->dataStack, length);
+
+ return;
+}
+
+
+
+/**************************************************************************
+ q u i t & a b o r t
+** quit CORE ( -- ) ( R: i*x -- )
+** Empty the return stack, store zero in SOURCE-ID if it is present, make
+** the user input device the input source, and enter interpretation state.
+** Do not display a message. Repeat the following:
+**
+** Accept a line from the input source into the input buffer, set >IN to
+** zero, and FICL_VM_STATE_INTERPRET.
+** Display the implementation-defined system prompt if in
+** interpretation state, all processing has been completed, and no
+** ambiguous condition exists.
+**************************************************************************/
+
+static void ficlPrimitiveQuit(ficlVm *vm)
+{
+ ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
+ return;
+}
+
+
+static void ficlPrimitiveAbort(ficlVm *vm)
+{
+ ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
+ return;
+}
+
+
+/**************************************************************************
+ a c c e p t
+** accept CORE ( c-addr +n1 -- +n2 )
+** Receive a string of at most +n1 characters. An ambiguous condition
+** exists if +n1 is zero or greater than 32,767. Display graphic characters
+** as they are received. A program that depends on the presence or absence
+** of non-graphic characters in the string has an environmental dependency.
+** The editing functions, if any, that the system performs in order to
+** construct the string are implementation-defined.
+**
+** (Although the standard text doesn't say so, I assume that the intent
+** of 'accept' is to store the string at the address specified on
+** the stack.)
+** Implementation: if there's more text in the TIB, use it. Otherwise
+** throw out for more text. Copy characters up to the max count into the
+** address given, and return the number of actual characters copied.
+**
+** Note (sobral) this may not be the behavior you'd expect if you're
+** trying to get user input at load time!
+**************************************************************************/
+static void ficlPrimitiveAccept(ficlVm *vm)
+{
+ ficlUnsigned size;
+ char *address;
+
+ ficlUnsigned length;
+ char *trace;
+ char *end;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 1);
+
+ trace = ficlVmGetInBuf(vm);
+ end = ficlVmGetInBufEnd(vm);
+ length = end - trace;
+ if (length == 0)
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+
+ /*
+ ** Now we have something in the text buffer - use it
+ */
+ size = ficlStackPopInteger(vm->dataStack);
+ address = ficlStackPopPointer(vm->dataStack);
+
+ length = (size < length) ? size : length;
+ strncpy(address, trace, length);
+ trace += length;
+ ficlVmUpdateTib(vm, trace);
+ ficlStackPushInteger(vm->dataStack, length);
+
+ return;
+}
+
+
+/**************************************************************************
+ a l i g n
+** 6.1.0705 ALIGN CORE ( -- )
+** If the data-space pointer is not aligned, reserve enough space to
+** align it.
+**************************************************************************/
+static void ficlPrimitiveAlign(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ FICL_IGNORE(vm);
+ ficlDictionaryAlign(dictionary);
+ return;
+}
+
+
+/**************************************************************************
+ a l i g n e d
+**
+**************************************************************************/
+static void ficlPrimitiveAligned(ficlVm *vm)
+{
+ void *addr;
+
+ FICL_STACK_CHECK(vm->dataStack,1,1);
+
+ addr = ficlStackPopPointer(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr));
+ return;
+}
+
+
+/**************************************************************************
+ b e g i n & f r i e n d s
+** Indefinite loop control structures
+** A.6.1.0760 BEGIN
+** Typical use:
+** : X ... BEGIN ... test UNTIL ;
+** or
+** : X ... BEGIN ... test WHILE ... REPEAT ;
+**************************************************************************/
+static void ficlPrimitiveBeginCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ markBranch(dictionary, vm, destTag);
+ return;
+}
+
+static void ficlPrimitiveUntilCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
+ resolveBackBranch(dictionary, vm, destTag);
+ return;
+}
+
+static void ficlPrimitiveWhileCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 5);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranch0ParenWithCheck);
+ markBranch(dictionary, vm, origTag);
+
+ /* equivalent to 2swap */
+ ficlStackRoll(vm->dataStack, 3);
+ ficlStackRoll(vm->dataStack, 3);
+
+ ficlDictionaryAppendUnsigned(dictionary, 1);
+ return;
+}
+
+static void ficlPrimitiveRepeatCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
+ /* expect "begin" branch marker */
+ resolveBackBranch(dictionary, vm, destTag);
+ /* expect "while" branch marker */
+ resolveForwardBranch(dictionary, vm, origTag);
+ return;
+}
+
+
+static void ficlPrimitiveAgainCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionBranchParenWithCheck);
+ /* expect "begin" branch marker */
+ resolveBackBranch(dictionary, vm, destTag);
+ return;
+}
+
+
+/**************************************************************************
+ c h a r & f r i e n d s
+** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
+** Skip leading space delimiters. Parse name delimited by a space.
+** Put the value of its first character onto the stack.
+**
+** bracket-char CORE
+** Interpretation: Interpretation semantics for this word are undefined.
+** Compilation: ( "<spaces>name" -- )
+** Skip leading space delimiters. Parse name delimited by a space.
+** Append the run-time semantics given below to the current definition.
+** Run-time: ( -- char )
+** Place char, the value of the first character of name, on the stack.
+**************************************************************************/
+static void ficlPrimitiveChar(ficlVm *vm)
+{
+ ficlString s;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ s = ficlVmGetWord(vm);
+ ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0]));
+ return;
+}
+
+static void ficlPrimitiveCharCoIm(ficlVm *vm)
+{
+ ficlPrimitiveChar(vm);
+ ficlPrimitiveLiteralIm(vm);
+ return;
+}
+
+/**************************************************************************
+ c h a r P l u s
+** char-plus CORE ( c-addr1 -- c-addr2 )
+** Add the size in address units of a character to c-addr1, giving c-addr2.
+**************************************************************************/
+static void ficlPrimitiveCharPlus(ficlVm *vm)
+{
+ char *p;
+
+ FICL_STACK_CHECK(vm->dataStack,1,1);
+
+
+ p = ficlStackPopPointer(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, p + 1);
+ return;
+}
+
+/**************************************************************************
+ c h a r s
+** chars CORE ( n1 -- n2 )
+** n2 is the size in address units of n1 characters.
+** For most processors, this function can be a no-op. To guarantee
+** portability, we'll multiply by sizeof (char).
+**************************************************************************/
+#if defined (_M_IX86)
+#pragma warning(disable: 4127)
+#endif
+static void ficlPrimitiveChars(ficlVm *vm)
+{
+ if (sizeof (char) > 1)
+ {
+ ficlInteger i;
+
+ FICL_STACK_CHECK(vm->dataStack,1,1);
+
+ i = ficlStackPopInteger(vm->dataStack);
+ ficlStackPushInteger(vm->dataStack, i * sizeof (char));
+ }
+ /* otherwise no-op! */
+ return;
+}
+#if defined (_M_IX86)
+#pragma warning(default: 4127)
+#endif
+
+
+/**************************************************************************
+ c o u n t
+** COUNT CORE ( c-addr1 -- c-addr2 u )
+** Return the character string specification for the counted string stored
+** at c-addr1. c-addr2 is the address of the first character after c-addr1.
+** u is the contents of the character at c-addr1, which is the length in
+** characters of the string at c-addr2.
+**************************************************************************/
+static void ficlPrimitiveCount(ficlVm *vm)
+{
+ ficlCountedString *counted;
+
+ FICL_STACK_CHECK(vm->dataStack,1,2);
+
+
+ counted = ficlStackPopPointer(vm->dataStack);
+ ficlStackPushPointer(vm->dataStack, counted->text);
+ ficlStackPushUnsigned(vm->dataStack, counted->length);
+ return;
+}
+
+/**************************************************************************
+ e n v i r o n m e n t ?
+** environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE )
+** c-addr is the address of a character string and u is the string's
+** character count. u may have a value in the range from zero to an
+** implementation-defined maximum which shall not be less than 31. The
+** character string should contain a keyword from 3.2.6 Environmental
+** queries or the optional word sets to be checked for correspondence
+** with an attribute of the present environment. If the system treats the
+** attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag
+** is FICL_TRUE and the i*x returned is of the type specified in the table for
+** the attribute queried.
+**************************************************************************/
+static void ficlPrimitiveEnvironmentQ(ficlVm *vm)
+{
+ ficlDictionary *environment;
+ ficlWord *word;
+ ficlString name;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 1);
+
+
+ environment = vm->callback.system->environment;
+ name.length = ficlStackPopUnsigned(vm->dataStack);
+ name.text = ficlStackPopPointer(vm->dataStack);
+
+ word = ficlDictionaryLookup(environment, name);
+
+ if (word != NULL)
+ {
+ ficlVmExecuteWord(vm, word);
+ ficlStackPushInteger(vm->dataStack, FICL_TRUE);
+ }
+ else
+ {
+ ficlStackPushInteger(vm->dataStack, FICL_FALSE);
+ }
+ return;
+}
+
+/**************************************************************************
+ e v a l u a t e
+** EVALUATE CORE ( i*x c-addr u -- j*x )
+** Save the current input source specification. Store minus-one (-1) in
+** SOURCE-ID if it is present. Make the string described by c-addr and u
+** both the input source and input buffer, set >IN to zero, and FICL_VM_STATE_INTERPRET.
+** When the parse area is empty, restore the prior input source
+** specification. Other stack effects are due to the words EVALUATEd.
+**
+**************************************************************************/
+static void ficlPrimitiveEvaluate(ficlVm *vm)
+{
+ ficlCell id;
+ int result;
+ ficlString string;
+
+ FICL_STACK_CHECK(vm->dataStack,2,0);
+
+
+ FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack));
+ FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack));
+
+ id = vm->sourceId;
+ vm->sourceId.i = -1;
+ result = ficlVmExecuteString(vm, string);
+ vm->sourceId = id;
+ if (result != FICL_VM_STATUS_OUT_OF_TEXT)
+ ficlVmThrow(vm, result);
+
+ return;
+}
+
+
+/**************************************************************************
+ s t r i n g q u o t e
+** Interpreting: get string delimited by a quote from the input stream,
+** copy to a scratch area, and put its count and address on the stack.
+** Compiling: FICL_VM_STATE_COMPILE code to push the address and count of a string
+** literal, FICL_VM_STATE_COMPILE the string from the input stream, and align the dictionary
+** pointer.
+**************************************************************************/
+static void ficlPrimitiveStringQuoteIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {
+ ficlCountedString *counted = (ficlCountedString *)dictionary->here;
+ ficlVmGetString(vm, counted, '\"');
+ ficlStackPushPointer(vm->dataStack, counted->text);
+ ficlStackPushUnsigned(vm->dataStack, counted->length);
+ }
+ else /* FICL_VM_STATE_COMPILE state */
+ {
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionStringLiteralParen);
+ dictionary->here = FICL_POINTER_TO_CELL(ficlVmGetString(vm, (ficlCountedString *)dictionary->here, '\"'));
+ ficlDictionaryAlign(dictionary);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ t y p e
+** Pop count and char address from stack and print the designated string.
+**************************************************************************/
+static void ficlPrimitiveType(ficlVm *vm)
+{
+ ficlUnsigned length;
+ char *s;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+
+ length = ficlStackPopUnsigned(vm->dataStack);
+ s = ficlStackPopPointer(vm->dataStack);
+
+ if ((s == NULL) || (length == 0))
+ return;
+
+ /*
+ ** Since we don't have an output primitive for a counted string
+ ** (oops), make sure the string is null terminated. If not, copy
+ ** and terminate it.
+ */
+ if (s[length] != 0)
+ {
+ char *here = (char *)ficlVmGetDictionary(vm)->here;
+ if (s != here)
+ strncpy(here, s, length);
+
+ here[length] = '\0';
+ s = here;
+ }
+
+ ficlVmTextOut(vm, s);
+ return;
+}
+
+/**************************************************************************
+ w o r d
+** word CORE ( char "<chars>ccc<char>" -- c-addr )
+** Skip leading delimiters. Parse characters ccc delimited by char. An
+** ambiguous condition exists if the length of the parsed string is greater
+** than the implementation-defined length of a counted string.
+**
+** c-addr is the address of a transient region containing the parsed word
+** as a counted string. If the parse area was empty or contained no
+** characters other than the delimiter, the resulting string has a zero
+** length. A space, not included in the length, follows the string. A
+** program may replace characters within the string.
+** NOTE! Ficl also NULL-terminates the dest string.
+**************************************************************************/
+static void ficlPrimitiveWord(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ char delim;
+ ficlString name;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 1);
+
+
+ counted = (ficlCountedString *)vm->pad;
+ delim = (char)ficlStackPopInteger(vm->dataStack);
+ name = ficlVmParseStringEx(vm, delim, 1);
+
+ if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1)
+ FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1);
+
+ counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
+ strncpy(counted->text, FICL_STRING_GET_POINTER(name), FICL_STRING_GET_LENGTH(name));
+
+ /* store an extra space at the end of the primitive... why? dunno yet. Guy Carver did it. */
+ counted->text[counted->length] = ' ';
+ counted->text[counted->length + 1] = 0;
+
+ ficlStackPushPointer(vm->dataStack, counted);
+ return;
+}
+
+
+/**************************************************************************
+ p a r s e - w o r d
+** Ficl PARSE-WORD ( <spaces>name -- c-addr u )
+** Skip leading spaces and parse name delimited by a space. c-addr is the
+** address within the input buffer and u is the length of the selected
+** string. If the parse area is empty, the resulting string has a zero length.
+**************************************************************************/
+static void ficlPrimitiveParseNoCopy(ficlVm *vm)
+{
+ ficlString s;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 2);
+
+
+ s = ficlVmGetWord0(vm);
+ ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
+ ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
+ return;
+}
+
+
+/**************************************************************************
+ p a r s e
+** CORE EXT ( char "ccc<char>" -- c-addr u )
+** Parse ccc delimited by the delimiter char.
+** c-addr is the address (within the input buffer) and u is the length of
+** the parsed string. If the parse area was empty, the resulting string has
+** a zero length.
+** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
+**************************************************************************/
+static void ficlPrimitiveParse(ficlVm *vm)
+{
+ ficlString s;
+ char delim;
+
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 2);
+
+
+ delim = (char)ficlStackPopInteger(vm->dataStack);
+
+ s = ficlVmParseStringEx(vm, delim, 0);
+ ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s));
+ ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s));
+ return;
+}
+
+
+/**************************************************************************
+ 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 do_find(ficlVm *vm, ficlString name, void *returnForFailure)
+{
+ ficlWord *word;
+
+ word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name);
+ if (word)
+ {
+ ficlStackPushPointer(vm->dataStack, word);
+ ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1));
+ }
+ else
+ {
+ ficlStackPushPointer(vm->dataStack, returnForFailure);
+ ficlStackPushUnsigned(vm->dataStack, 0);
+ }
+ return;
+}
+
+
+
+/**************************************************************************
+ 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 ficlPrimitiveCFind(ficlVm *vm)
+{
+ ficlCountedString *counted;
+ ficlString name;
+
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 2);
+
+ counted = ficlStackPopPointer(vm->dataStack);
+ FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted);
+ do_find(vm, name, counted);
+}
+
+
+
+/**************************************************************************
+ 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 ficlPrimitiveSFind(ficlVm *vm)
+{
+ ficlString name;
+
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+
+ name.length = ficlStackPopInteger(vm->dataStack);
+ name.text = ficlStackPopPointer(vm->dataStack);
+
+ do_find(vm, name, NULL);
+}
+
+
+
+/**************************************************************************
+ r e c u r s e
+**
+**************************************************************************/
+static void ficlPrimitiveRecurseCoIm(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_IGNORE(vm);
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(dictionary->smudge));
+ return;
+}
+
+
+/**************************************************************************
+ s o u r c e
+** CORE ( -- c-addr u )
+** c-addr is the address of, and u is the number of characters in, the
+** input buffer.
+**************************************************************************/
+static void ficlPrimitiveSource(ficlVm *vm)
+{
+
+ FICL_STACK_CHECK(vm->dataStack,0,2);
+
+ ficlStackPushPointer(vm->dataStack, vm->tib.text);
+ ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm));
+ return;
+}
+
+
+/**************************************************************************
+ v e r s i o n
+** non-standard...
+**************************************************************************/
+static void ficlPrimitiveVersion(ficlVm *vm)
+{
+ ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n");
+ return;
+}
+
+
+/**************************************************************************
+ t o I n
+** to-in CORE
+**************************************************************************/
+static void ficlPrimitiveToIn(ficlVm *vm)
+{
+
+ FICL_STACK_CHECK(vm->dataStack,0,1);
+
+ ficlStackPushPointer(vm->dataStack, &vm->tib.index);
+ return;
+}
+
+
+/**************************************************************************
+ c o l o n N o N a m e
+** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
+** Create an unnamed colon definition and push its address.
+** Change state to FICL_VM_STATE_COMPILE.
+**************************************************************************/
+static void ficlPrimitiveColonNoName(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *word;
+ ficlString name;
+
+ FICL_STRING_SET_LENGTH(name, 0);
+ FICL_STRING_SET_POINTER(name, NULL);
+
+ vm->state = FICL_VM_STATE_COMPILE;
+ word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionColonParen, FICL_WORD_DEFAULT | FICL_WORD_SMUDGED);
+ ficlStackPushPointer(vm->dataStack, word);
+ markControlTag(vm, colonTag);
+ return;
+}
+
+
+/**************************************************************************
+ u s e r V a r i a b l e
+** user ( u -- ) "<spaces>name"
+** Get a name from the input stream and create a user variable
+** with the name and the index supplied. The run-time effect
+** of a user variable is to push the address of the indexed ficlCell
+** in the running vm's user array.
+**
+** User variables are vm local cells. Each vm has an array of
+** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
+** Ficl's user facility is implemented with two primitives,
+** "user" and "(user)", a variable ("nUser") (in softcore.c) that
+** holds the index of the next free user ficlCell, and a redefinition
+** (also in softcore) of "user" that defines a user word and increments
+** nUser.
+**************************************************************************/
+#if FICL_WANT_USER
+static void ficlPrimitiveUser(ficlVm *vm)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+ ficlCell c;
+
+ c = ficlStackPop(vm->dataStack);
+ if (c.i >= FICL_USER_CELLS)
+ {
+ ficlVmThrowError(vm, "Error - out of user space");
+ }
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, c);
+ return;
+}
+#endif
+
+
+#if FICL_WANT_LOCALS
+/*
+** Each local is recorded in a private locals dictionary as a
+** word that does doLocalIm at runtime. DoLocalIm compiles code
+** into the client definition to fetch the value of the
+** corresponding local variable from the return stack.
+** The private dictionary gets initialized at the end of each block
+** that uses locals (in ; and does> for example).
+*/
+void ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat)
+{
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlInteger nLocal = vm->runningWord->param[0].i;
+
+#if !FICL_WANT_FLOAT
+ FICL_VM_ASSERT(vm, !isFloat);
+ /* get rid of unused parameter warning */
+ isFloat = 0;
+#endif /* FICL_WANT_FLOAT */
+
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {
+ ficlStack *stack;
+#if FICL_WANT_FLOAT
+ if (isFloat)
+ stack = vm->floatStack;
+ else
+#endif /* FICL_WANT_FLOAT */
+ stack = vm->dataStack;
+
+ ficlStackPush(stack, vm->returnStack->frame[nLocal]);
+ if (isDouble)
+ ficlStackPush(stack, vm->returnStack->frame[nLocal+1]);
+ }
+ else
+ {
+ ficlInstruction instruction;
+ ficlInteger appendLocalOffset;
+#if FICL_WANT_FLOAT
+ if (isFloat)
+ {
+ instruction = (isDouble) ? ficlInstructionGetF2LocalParen : ficlInstructionGetFLocalParen;
+ appendLocalOffset = FICL_TRUE;
+ }
+ else
+#endif /* FICL_WANT_FLOAT */
+ if (nLocal == 0)
+ {
+ instruction = (isDouble) ? ficlInstructionGet2Local0 : ficlInstructionGetLocal0;
+ appendLocalOffset = FICL_FALSE;
+ }
+ else if ((nLocal == 1) && !isDouble)
+ {
+ instruction = ficlInstructionGetLocal1;
+ appendLocalOffset = FICL_FALSE;
+ }
+ else
+ {
+ instruction = (isDouble) ? ficlInstructionGet2LocalParen : ficlInstructionGetLocalParen;
+ appendLocalOffset = FICL_TRUE;
+ }
+
+ ficlDictionaryAppendUnsigned(dictionary, instruction);
+ if (appendLocalOffset)
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(nLocal));
+ }
+ return;
+}
+
+static void ficlPrimitiveDoLocalIm(ficlVm *vm)
+{
+ ficlLocalParenIm(vm, 0, 0);
+}
+
+static void ficlPrimitiveDo2LocalIm(ficlVm *vm)
+{
+ ficlLocalParenIm(vm, 1, 0);
+}
+
+#if FICL_WANT_FLOAT
+static void ficlPrimitiveDoFLocalIm(ficlVm *vm)
+{
+ ficlLocalParenIm(vm, 0, 1);
+}
+
+static void ficlPrimitiveDoF2LocalIm(ficlVm *vm)
+{
+ ficlLocalParenIm(vm, 1, 1);
+}
+#endif /* FICL_WANT_FLOAT */
+
+
+
+/**************************************************************************
+ l o c a l P a r e n
+** paren-local-paren LOCAL
+** Interpretation: Interpretation semantics for this word are undefined.
+** Execution: ( c-addr u -- )
+** When executed during compilation, (LOCAL) passes a message to the
+** system that has one of two meanings. If u is non-zero,
+** the message identifies a new local whose definition name is given by
+** the string of characters identified by c-addr u. If u is zero,
+** the message is last local and c-addr has no significance.
+**
+** The result of executing (LOCAL) during compilation of a definition is
+** to create a set of named local identifiers, each of which is
+** a definition name, that only have execution semantics within the scope
+** of that definition's source.
+**
+** local Execution: ( -- x )
+**
+** Push the local's value, x, onto the stack. The local's value is
+** initialized as described in 13.3.3 Processing locals and may be
+** changed by preceding the local's name with TO. An ambiguous condition
+** exists when local is executed while in interpretation state.
+**************************************************************************/
+void ficlLocalParen(ficlVm *vm, int isDouble, int isFloat)
+{
+ ficlDictionary *dictionary;
+ ficlString name;
+
+ FICL_STACK_CHECK(vm->dataStack,2,0);
+
+
+ dictionary = ficlVmGetDictionary(vm);
+ FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack));
+ FICL_STRING_SET_POINTER(name, (char *)ficlStackPopPointer(vm->dataStack));
+
+ if (FICL_STRING_GET_LENGTH(name) > 0)
+ { /* add a local to the **locals** dictionary and update localsCount */
+ ficlPrimitive code;
+ ficlInstruction instruction;
+ ficlDictionary *locals = ficlSystemGetLocals(vm->callback.system);
+ if (vm->callback.system->localsCount >= FICL_MAX_LOCALS)
+ {
+ ficlVmThrowError(vm, "Error: out of local space");
+ }
+
+#if !FICL_WANT_FLOAT
+ FICL_VM_ASSERT(vm, !isFloat);
+ /* get rid of unused parameter warning */
+ isFloat = 0;
+#else /* FICL_WANT_FLOAT */
+ if (isFloat)
+ {
+ if (isDouble)
+ {
+ code = ficlPrimitiveDoF2LocalIm;
+ instruction = ficlInstructionToF2LocalParen;
+ }
+ else
+ {
+ code = ficlPrimitiveDoFLocalIm;
+ instruction = ficlInstructionToFLocalParen;
+ }
+ }
+ else
+#endif /* FICL_WANT_FLOAT */
+ if (isDouble)
+ {
+ code = ficlPrimitiveDo2LocalIm;
+ instruction = ficlInstructionTo2LocalParen;
+ }
+ else
+ {
+ code = ficlPrimitiveDoLocalIm;
+ instruction = ficlInstructionToLocalParen;
+ }
+
+ ficlDictionaryAppendWord(locals, name, code, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionaryAppendCell(locals, FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));
+
+ if (vm->callback.system->localsCount == 0)
+ { /* FICL_VM_STATE_COMPILE code to create a local stack frame */
+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLinkParen);
+ /* save location in dictionary for #locals */
+ vm->callback.system->localsFixup = dictionary->here;
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));
+ }
+
+ ficlDictionaryAppendUnsigned(dictionary, instruction);
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(vm->callback.system->localsCount));
+
+ vm->callback.system->localsCount += (isDouble) ? 2 : 1;
+ }
+ else if (vm->callback.system->localsCount > 0)
+ {
+ /* write localsCount to (link) param area in dictionary */
+ *(ficlInteger *)(vm->callback.system->localsFixup) = vm->callback.system->localsCount;
+ }
+
+ return;
+}
+
+
+static void ficlPrimitiveLocalParen(ficlVm *vm)
+{
+ ficlLocalParen(vm, 0, 0);
+}
+
+static void ficlPrimitive2LocalParen(ficlVm *vm)
+{
+ ficlLocalParen(vm, 1, 0);
+}
+
+
+#endif /* FICL_WANT_LOCALS */
+
+
+/**************************************************************************
+ t o V a l u e
+** CORE EXT
+** Interpretation: ( x "<spaces>name" -- )
+** Skip leading spaces and parse name delimited by a space. Store x in
+** name. An ambiguous condition exists if name was not defined by VALUE.
+** NOTE: In Ficl, VALUE is an alias of CONSTANT
+**************************************************************************/
+static void ficlPrimitiveToValue(ficlVm *vm)
+{
+ ficlString name = ficlVmGetWord(vm);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *word;
+ ficlInstruction instruction = 0;
+ ficlStack *stack;
+ ficlInteger isDouble;
+#if FICL_WANT_LOCALS
+ ficlInteger nLocal;
+ ficlInteger appendLocalOffset;
+ ficlInteger isFloat;
+#endif /* FICL_WANT_LOCALS */
+
+#if FICL_WANT_LOCALS
+ if ((vm->callback.system->localsCount > 0) && (vm->state == FICL_VM_STATE_COMPILE))
+ {
+ ficlDictionary *locals;
+
+ locals = ficlSystemGetLocals(vm->callback.system);
+ word = ficlDictionaryLookup(locals, name);
+ if (!word)
+ goto TO_GLOBAL;
+
+ if (word->code == ficlPrimitiveDoLocalIm)
+ {
+ instruction = ficlInstructionToLocalParen;
+ isDouble = isFloat = FICL_FALSE;
+ }
+ else if (word->code == ficlPrimitiveDo2LocalIm)
+ {
+ instruction = ficlInstructionTo2LocalParen;
+ isDouble = FICL_TRUE;
+ isFloat = FICL_FALSE;
+ }
+#if FICL_WANT_FLOAT
+ else if (word->code == ficlPrimitiveDoFLocalIm)
+ {
+ instruction = ficlInstructionToFLocalParen;
+ isDouble = FICL_FALSE;
+ isFloat = FICL_TRUE;
+ }
+ else if (word->code == ficlPrimitiveDoF2LocalIm)
+ {
+ instruction = ficlInstructionToF2LocalParen;
+ isDouble = isFloat = FICL_TRUE;
+ }
+#endif /* FICL_WANT_FLOAT */
+ else
+ {
+ ficlVmThrowError(vm, "to %.*s : local is of unknown type", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
+ return;
+ }
+
+ nLocal = word->param[0].i;
+ appendLocalOffset = FICL_TRUE;
+
+#if FICL_WANT_FLOAT
+ if (!isFloat)
+ {
+#endif /* FICL_WANT_FLOAT */
+ if (nLocal == 0)
+ {
+ instruction = (isDouble) ? ficlInstructionTo2Local0 : ficlInstructionToLocal0;
+ appendLocalOffset = FICL_FALSE;
+ }
+ else if ((nLocal == 1) && !isDouble)
+ {
+ instruction = ficlInstructionToLocal1;
+ appendLocalOffset = FICL_FALSE;
+ }
+#if FICL_WANT_FLOAT
+ }
+#endif /* FICL_WANT_FLOAT */
+
+ ficlDictionaryAppendUnsigned(dictionary, instruction);
+ if (appendLocalOffset)
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(nLocal));
+ return;
+ }
+#endif
+
+#if FICL_WANT_LOCALS
+TO_GLOBAL:
+#endif /* FICL_WANT_LOCALS */
+ word = ficlDictionaryLookup(dictionary, name);
+ if (!word)
+ ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
+
+ switch ((ficlInstruction)word->code)
+ {
+ case ficlInstructionConstantParen:
+ instruction = ficlInstructionStore;
+ stack = vm->dataStack;
+ isDouble = FICL_FALSE;
+ break;
+ case ficlInstruction2ConstantParen:
+ instruction = ficlInstruction2Store;
+ stack = vm->dataStack;
+ isDouble = FICL_TRUE;
+ break;
+#if FICL_WANT_FLOAT
+ case ficlInstructionFConstantParen:
+ instruction = ficlInstructionFStore;
+ stack = vm->floatStack;
+ isDouble = FICL_FALSE;
+ break;
+ case ficlInstructionF2ConstantParen:
+ instruction = ficlInstructionF2Store;
+ stack = vm->floatStack;
+ isDouble = FICL_TRUE;
+ break;
+#endif /* FICL_WANT_FLOAT */
+ default:
+ {
+ ficlVmThrowError(vm, "to %.*s : value/constant is of unknown type", FICL_STRING_GET_LENGTH(name), FICL_STRING_GET_POINTER(name));
+ return;
+ }
+ }
+
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {
+ word->param[0] = ficlStackPop(stack);
+ if (isDouble)
+ word->param[1] = ficlStackPop(stack);
+ }
+ else /* FICL_VM_STATE_COMPILE code to store to word's param */
+ {
+ ficlStackPushPointer(vm->dataStack, &word->param[0]);
+ ficlPrimitiveLiteralIm(vm);
+ ficlDictionaryAppendUnsigned(dictionary, instruction);
+ }
+ return;
+}
+
+
+/**************************************************************************
+ 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.
+** Input and output stack arguments are signed. An ambiguous condition
+** exists if n1 is zero or if the quotient lies outside the range of a
+** single-ficlCell signed integer.
+**************************************************************************/
+static void ficlPrimitiveFMSlashMod(ficlVm *vm)
+{
+ ficl2Integer d1;
+ ficlInteger n1;
+ ficl2IntegerQR qr;
+
+ FICL_STACK_CHECK(vm->dataStack, 3, 2);
+
+ n1 = ficlStackPopInteger(vm->dataStack);
+ d1 = ficlStackPop2Integer(vm->dataStack);
+ qr = ficl2IntegerDivideFloored(d1, n1);
+ ficlStackPushInteger(vm->dataStack, qr.remainder);
+ ficlStackPushInteger(vm->dataStack, FICL_2UNSIGNED_GET_LOW(qr.quotient));
+ return;
+}
+
+
+/**************************************************************************
+ s m S l a s h R e m
+** s-m-slash-remainder CORE ( d1 n1 -- n2 n3 )
+** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
+** Input and output stack arguments are signed. An ambiguous condition
+** exists if n1 is zero or if the quotient lies outside the range of a
+** single-ficlCell signed integer.
+**************************************************************************/
+static void ficlPrimitiveSMSlashRem(ficlVm *vm)
+{
+ ficl2Integer d1;
+ ficlInteger n1;
+ ficl2IntegerQR qr;
+
+ FICL_STACK_CHECK(vm->dataStack, 3, 2);
+
+ n1 = ficlStackPopInteger(vm->dataStack);
+ d1 = ficlStackPop2Integer(vm->dataStack);
+ qr = ficl2IntegerDivideSymmetric(d1, n1);
+ ficlStackPushInteger(vm->dataStack, qr.remainder);
+ ficlStackPushInteger(vm->dataStack, FICL_2UNSIGNED_GET_LOW(qr.quotient));
+ return;
+}
+
+
+static void ficlPrimitiveMod(ficlVm *vm)
+{
+ ficl2Integer d1;
+ ficlInteger n1;
+ ficlInteger i;
+ ficl2IntegerQR qr;
+ FICL_STACK_CHECK(vm->dataStack, 2, 1);
+
+ n1 = ficlStackPopInteger(vm->dataStack);
+ i = ficlStackPopInteger(vm->dataStack);
+ FICL_INTEGER_TO_2INTEGER(i, d1);
+ qr = ficl2IntegerDivideSymmetric(d1, n1);
+ ficlStackPushInteger(vm->dataStack, qr.remainder);
+ return;
+}
+
+
+/**************************************************************************
+ u m S l a s h M o d
+** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
+** Divide ud by u1, giving the quotient u3 and the remainder u2.
+** All values and arithmetic are unsigned. An ambiguous condition
+** exists if u1 is zero or if the quotient lies outside the range of a
+** single-ficlCell unsigned integer.
+*************************************************************************/
+static void ficlPrimitiveUMSlashMod(ficlVm *vm)
+{
+ ficl2Unsigned ud;
+ ficlUnsigned u1;
+ ficl2UnsignedQR uqr;
+
+ u1 = ficlStackPopUnsigned(vm->dataStack);
+ ud = ficlStackPop2Unsigned(vm->dataStack);
+ uqr = ficl2UnsignedDivide(ud, u1);
+ ficlStackPushUnsigned(vm->dataStack, uqr.remainder);
+ ficlStackPushUnsigned(vm->dataStack, FICL_2UNSIGNED_GET_LOW(uqr.quotient));
+ return;
+}
+
+
+
+/**************************************************************************
+ m S t a r
+** m-star CORE ( n1 n2 -- d )
+** d is the signed product of n1 times n2.
+**************************************************************************/
+static void ficlPrimitiveMStar(ficlVm *vm)
+{
+ ficlInteger n2;
+ ficlInteger n1;
+ ficl2Integer d;
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+ n2 = ficlStackPopInteger(vm->dataStack);
+ n1 = ficlStackPopInteger(vm->dataStack);
+
+ d = ficl2IntegerMultiply(n1, n2);
+ ficlStackPush2Integer(vm->dataStack, d);
+ return;
+}
+
+
+static void ficlPrimitiveUMStar(ficlVm *vm)
+{
+ ficlUnsigned u2;
+ ficlUnsigned u1;
+ ficl2Unsigned ud;
+ FICL_STACK_CHECK(vm->dataStack, 2, 2);
+
+ u2 = ficlStackPopUnsigned(vm->dataStack);
+ u1 = ficlStackPopUnsigned(vm->dataStack);
+
+ ud = ficl2UnsignedMultiply(u1, u2);
+ ficlStackPush2Unsigned(vm->dataStack, ud);
+ return;
+}
+
+
+/**************************************************************************
+ d n e g a t e
+** DOUBLE ( d1 -- d2 )
+** d2 is the negation of d1.
+**************************************************************************/
+static void ficlPrimitiveDNegate(ficlVm *vm)
+{
+ ficl2Integer i = ficlStackPop2Integer(vm->dataStack);
+ i = ficl2IntegerNegate(i);
+ ficlStackPush2Integer(vm->dataStack, i);
+
+ return;
+}
+
+
+
+
+/**************************************************************************
+ 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 ficlPrimitivePad(ficlVm *vm)
+{
+ ficlStackPushPointer(vm->dataStack, vm->pad);
+}
+
+
+/**************************************************************************
+ s o u r c e - i d
+** CORE EXT, FILE ( -- 0 | -1 | fileid )
+** Identifies the input source as follows:
+**
+** SOURCE-ID Input source
+** --------- ------------
+** fileid Text file fileid
+** -1 String (via EVALUATE)
+** 0 User input device
+**************************************************************************/
+static void ficlPrimitiveSourceID(ficlVm *vm)
+{
+ ficlStackPushInteger(vm->dataStack, vm->sourceId.i);
+ return;
+}
+
+
+/**************************************************************************
+ r e f i l l
+** CORE EXT ( -- flag )
+** Attempt to fill the input buffer from the input source, returning a FICL_TRUE
+** flag if successful.
+** When the input source is the user input device, attempt to receive input
+** into the terminal input buffer. If successful, make the result the input
+** buffer, set >IN to zero, and return FICL_TRUE. Receipt of a line containing no
+** characters is considered successful. If there is no input available from
+** the current input source, return FICL_FALSE.
+** When the input source is a string from EVALUATE, return FICL_FALSE and
+** perform no other action.
+**************************************************************************/
+static void ficlPrimitiveRefill(ficlVm *vm)
+{
+ ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE;
+ if (ret && (vm->restart == 0))
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+
+ ficlStackPushInteger(vm->dataStack, ret);
+ return;
+}
+
+
+/**************************************************************************
+ freebsd exception handling words
+** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
+** the word in ToS. If an exception happens, restore the state to what
+** it was before, and pushes the exception value on the stack. If not,
+** push zero.
+**
+** Notice that Catch implements an inner interpreter. This is ugly,
+** but given how Ficl works, it cannot be helped. The problem is that
+** colon definitions will be executed *after* the function returns,
+** while "code" definitions will be executed immediately. I considered
+** other solutions to this problem, but all of them shared the same
+** basic problem (with added disadvantages): if Ficl ever changes it's
+** inner thread modus operandi, one would have to fix this word.
+**
+** More comments can be found throughout catch's code.
+**
+** Daniel C. Sobral Jan 09/1999
+** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
+**************************************************************************/
+
+static void ficlPrimitiveCatch(ficlVm *vm)
+{
+ int except;
+ jmp_buf vmState;
+ ficlVm vmCopy;
+ ficlStack dataStackCopy;
+ ficlStack returnStackCopy;
+ ficlWord *word;
+
+ FICL_VM_ASSERT(vm, vm);
+ FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
+
+
+ /*
+ ** Get xt.
+ ** We need this *before* we save the stack pointer, or
+ ** we'll have to pop one element out of the stack after
+ ** an exception. I prefer to get done with it up front. :-)
+ */
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ word = ficlStackPopPointer(vm->dataStack);
+
+ /*
+ ** Save vm's state -- a catch will not back out environmental
+ ** changes.
+ **
+ ** We are *not* saving dictionary state, since it is
+ ** global instead of per vm, and we are not saving
+ ** stack contents, since we are not required to (and,
+ ** thus, it would be useless). We save vm, and vm
+ ** "stacks" (a structure containing general information
+ ** about it, including the current stack pointer).
+ */
+ memcpy((void*)&vmCopy, (void*)vm, sizeof(ficlVm));
+ memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof(ficlStack));
+ memcpy((void*)&returnStackCopy, (void*)vm->returnStack, sizeof(ficlStack));
+
+ /*
+ ** Give vm a jmp_buf
+ */
+ vm->exceptionHandler = &vmState;
+
+ /*
+ ** Safety net
+ */
+ except = setjmp(vmState);
+
+ switch (except)
+ {
+ /*
+ ** Setup condition - push poison pill so that the VM throws
+ ** VM_INNEREXIT if the XT terminates normally, then execute
+ ** the XT
+ */
+ case 0:
+ ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); /* Open mouth, insert emetic */
+ ficlVmExecuteWord(vm, word);
+ ficlVmInnerLoop(vm, 0);
+ break;
+
+ /*
+ ** Normal exit from XT - lose the poison pill,
+ ** restore old setjmp vector and push a zero.
+ */
+ case FICL_VM_STATUS_INNER_EXIT:
+ ficlVmPopIP(vm); /* Gack - hurl poison pill */
+ vm->exceptionHandler = vmCopy.exceptionHandler; /* Restore just the setjmp vector */
+ ficlStackPushInteger(vm->dataStack, 0); /* Push 0 -- everything is ok */
+ break;
+
+ /*
+ ** Some other exception got thrown - restore pre-existing VM state
+ ** and push the exception code
+ */
+ default:
+ /* Restore vm's state */
+ memcpy((void*)vm, (void*)&vmCopy, sizeof(ficlVm));
+ memcpy((void*)vm->dataStack, (void*)&dataStackCopy, sizeof(ficlStack));
+ memcpy((void*)vm->returnStack, (void*)&returnStackCopy, sizeof(ficlStack));
+
+ ficlStackPushInteger(vm->dataStack, except);/* Push error */
+ break;
+ }
+}
+
+/**************************************************************************
+** t h r o w
+** EXCEPTION
+** Throw -- From ANS Forth standard.
+**
+** Throw takes the ToS and, if that's different from zero,
+** returns to the last executed catch context. Further throws will
+** unstack previously executed "catches", in LIFO mode.
+**
+** Daniel C. Sobral Jan 09/1999
+**************************************************************************/
+static void ficlPrimitiveThrow(ficlVm *vm)
+{
+ int except;
+
+ except = ficlStackPopInteger(vm->dataStack);
+
+ if (except)
+ ficlVmThrow(vm, except);
+}
+
+
+/**************************************************************************
+** a l l o c a t e
+** MEMORY
+**************************************************************************/
+static void ficlPrimitiveAllocate(ficlVm *vm)
+{
+ size_t size;
+ void *p;
+
+ size = ficlStackPopInteger(vm->dataStack);
+ p = ficlMalloc(size);
+ ficlStackPushPointer(vm->dataStack, p);
+ if (p)
+ ficlStackPushInteger(vm->dataStack, 0);
+ else
+ ficlStackPushInteger(vm->dataStack, 1);
+}
+
+
+/**************************************************************************
+** f r e e
+** MEMORY
+**************************************************************************/
+static void ficlPrimitiveFree(ficlVm *vm)
+{
+ void *p;
+
+ p = ficlStackPopPointer(vm->dataStack);
+ ficlFree(p);
+ ficlStackPushInteger(vm->dataStack, 0);
+}
+
+
+/**************************************************************************
+** r e s i z e
+** MEMORY
+**************************************************************************/
+static void ficlPrimitiveResize(ficlVm *vm)
+{
+ size_t size;
+ void *new, *old;
+
+ size = ficlStackPopInteger(vm->dataStack);
+ old = ficlStackPopPointer(vm->dataStack);
+ new = ficlRealloc(old, size);
+ if (new)
+ {
+ ficlStackPushPointer(vm->dataStack, new);
+ ficlStackPushInteger(vm->dataStack, 0);
+ }
+ else
+ {
+ ficlStackPushPointer(vm->dataStack, old);
+ ficlStackPushInteger(vm->dataStack, 1);
+ }
+}
+
+
+/**************************************************************************
+** e x i t - i n n e r
+** Signals execXT that an inner loop has completed
+**************************************************************************/
+static void ficlPrimitiveExitInner(ficlVm *vm)
+{
+ ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT);
+}
+
+
+#if 0
+/**************************************************************************
+
+**
+**************************************************************************/
+static void ficlPrimitiveName(ficlVm *vm)
+{
+ FICL_IGNORE(vm);
+ return;
+}
+
+
+#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.
+**************************************************************************/
+
+void ficlSystemCompileCore(ficlSystem *system)
+{
+ ficlWord *interpret;
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+
+ #define FICL_TOKEN(token, description)
+ #define FICL_INSTRUCTION_TOKEN(token, description, flags) ficlDictionarySetInstruction(dictionary, description, token, flags);
+ #include "ficltokens.h"
+ #undef FICL_TOKEN
+ #undef FICL_INSTRUCTION_TOKEN
+
+ /*
+ ** The Core word set
+ ** see softcore.c for definitions of: abs bl space spaces abort"
+ */
+ ficlDictionarySetPrimitive(dictionary, "#", ficlPrimitiveNumberSign, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "#>", ficlPrimitiveNumberSignGreater,FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "#s", ficlPrimitiveNumberSignS, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "\'", ficlPrimitiveTick, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "(", ficlPrimitiveParenthesis, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "+loop", ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, ".", ficlPrimitiveDot, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".\"", ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, ":", ficlPrimitiveColon, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ";", ficlPrimitiveSemicolonCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "<#", ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ">body", ficlPrimitiveToBody, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ">in", ficlPrimitiveToIn, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ">number", ficlPrimitiveToNumber, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "abort", ficlPrimitiveAbort, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "accept", ficlPrimitiveAccept, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "align", ficlPrimitiveAlign, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "aligned", ficlPrimitiveAligned, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "allot", ficlPrimitiveAllot, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "base", ficlPrimitiveBase, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "begin", ficlPrimitiveBeginCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "case", ficlPrimitiveCaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "char", ficlPrimitiveChar, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "char+", ficlPrimitiveCharPlus, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "chars", ficlPrimitiveChars, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "constant", ficlPrimitiveConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "count", ficlPrimitiveCount, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "cr", ficlPrimitiveCR, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "create", ficlPrimitiveCreate, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "decimal", ficlPrimitiveDecimal, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "depth", ficlPrimitiveDepth, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "do", ficlPrimitiveDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "does>", ficlPrimitiveDoesCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "else", ficlPrimitiveElseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "emit", ficlPrimitiveEmit, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "endcase", ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "endof", ficlPrimitiveEndofCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "environment?", ficlPrimitiveEnvironmentQ,FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "evaluate", ficlPrimitiveEvaluate, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "execute", ficlPrimitiveExecute, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "exit", ficlPrimitiveExitCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "fallthrough",ficlPrimitiveFallthroughCoIm,FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "find", ficlPrimitiveCFind, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fm/mod", ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "here", ficlPrimitiveHere, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "hold", ficlPrimitiveHold, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "if", ficlPrimitiveIfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "immediate", ficlPrimitiveImmediate, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "literal", ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "loop", ficlPrimitiveLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "m*", ficlPrimitiveMStar, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "mod", ficlPrimitiveMod, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "of", ficlPrimitiveOfCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "postpone", ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "quit", ficlPrimitiveQuit, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "recurse", ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "repeat", ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "s\"", ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "sign", ficlPrimitiveSign, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "sm/rem", ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "source", ficlPrimitiveSource, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "state", ficlPrimitiveState, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "then", ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "type", ficlPrimitiveType, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "u.", ficlPrimitiveUDot, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "um*", ficlPrimitiveUMStar, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "um/mod", ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "until", ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "variable", ficlPrimitiveVariable, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "while", ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "word", ficlPrimitiveWord, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "[", ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "[\']", ficlPrimitiveBracketTickCoIm,FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "[char]", ficlPrimitiveCharCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "]", ficlPrimitiveRightBracket, FICL_WORD_DEFAULT);
+ /*
+ ** The Core Extensions word set...
+ ** see softcore.fr for other definitions
+ */
+ /* "#tib" */
+ ficlDictionarySetPrimitive(dictionary, ".(", ficlPrimitiveDotParen, FICL_WORD_IMMEDIATE);
+ /* ".r" */
+ ficlDictionarySetPrimitive(dictionary, ":noname", ficlPrimitiveColonNoName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "?do", ficlPrimitiveQDoCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "again", ficlPrimitiveAgainCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "c\"", ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "hex", ficlPrimitiveHex, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "pad", ficlPrimitivePad, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "parse", ficlPrimitiveParse, FICL_WORD_DEFAULT);
+ /* query restore-input save-input tib u.r u> unused [FICL_VM_STATE_COMPILE] */
+ ficlDictionarySetPrimitive(dictionary, "refill", ficlPrimitiveRefill, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "source-id", ficlPrimitiveSourceID, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "to", ficlPrimitiveToValue, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "value", ficlPrimitiveConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "\\", ficlPrimitiveBackslash, FICL_WORD_IMMEDIATE);
+
+
+ /*
+ ** Environment query values for the Core word set
+ */
+ ficlDictionarySetConstant(environment, "/counted-string", FICL_COUNTED_STRING_MAX);
+ ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE);
+ ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE);
+ ficlDictionarySetConstant(environment, "address-unit-bits", 8);
+ ficlDictionarySetConstant(environment, "core", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "floored", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX);
+ ficlDictionarySetConstant(environment, "max-n", 0x7fffffff);
+ ficlDictionarySetConstant(environment, "max-u", 0xffffffff);
+ {
+ ficl2Unsigned combined;
+ FICL_2UNSIGNED_SET(INT_MAX, UINT_MAX, combined);
+ ficlDictionarySet2Constant(environment,"max-d", FICL_2UNSIGNED_TO_2INTEGER(combined));
+ FICL_2UNSIGNED_SET(UINT_MAX, UINT_MAX, combined);
+ ficlDictionarySet2Constant(environment,"max-ud", FICL_2UNSIGNED_TO_2INTEGER(combined));
+ }
+ ficlDictionarySetConstant(environment, "return-stack-cells",FICL_DEFAULT_STACK_SIZE);
+ ficlDictionarySetConstant(environment, "stack-cells", FICL_DEFAULT_STACK_SIZE);
+
+ /*
+ ** The optional Double-Number word set (partial)
+ */
+ ficlDictionarySetPrimitive(dictionary, "2constant", ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "2value", ficlPrimitive2Constant, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "2literal", ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "2variable", ficlPrimitive2Variable, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "dnegate", ficlPrimitiveDNegate, FICL_WORD_DEFAULT);
+
+
+ /*
+ ** The optional Exception and Exception Extensions word set
+ */
+ ficlDictionarySetPrimitive(dictionary, "catch", ficlPrimitiveCatch, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "throw", ficlPrimitiveThrow, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetConstant(environment, "exception", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "exception-ext", FICL_TRUE);
+
+ /*
+ ** The optional Locals and Locals Extensions word set
+ ** see softcore.c for implementation of locals|
+ */
+#if FICL_WANT_LOCALS
+ ficlDictionarySetPrimitive(dictionary, "doLocal", ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "(local)", ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY);
+ ficlDictionarySetPrimitive(dictionary, "(2local)", ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY);
+
+ ficlDictionarySetConstant(environment, "locals", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "#locals", FICL_MAX_LOCALS);
+#endif
+
+ /*
+ ** The optional Memory-Allocation word set
+ */
+
+ ficlDictionarySetPrimitive(dictionary, "allocate", ficlPrimitiveAllocate, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "free", ficlPrimitiveFree, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "resize", ficlPrimitiveResize, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetConstant(environment, "memory-alloc", FICL_TRUE);
+
+ /*
+ ** The optional Search-Order word set
+ */
+ ficlSystemCompileSearch(system);
+
+ /*
+ ** The optional Programming-Tools and Programming-Tools Extensions word set
+ */
+ ficlSystemCompileTools(system);
+
+ /*
+ ** The optional File-Access and File-Access Extensions word set
+ */
+#if FICL_WANT_FILE
+ ficlSystemCompileFile(system);
+#endif
+
+ /*
+ ** Ficl extras
+ */
+ ficlDictionarySetPrimitive(dictionary, ".ver", ficlPrimitiveVersion, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ">name", ficlPrimitiveToName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "add-parse-step",
+ ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "body>", ficlPrimitiveFromBody, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "compile-only",
+ ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "endif", ficlPrimitiveEndifCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "last-word", ficlPrimitiveLastWord, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "hash", ficlPrimitiveHash, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "objectify", ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "?object", ficlPrimitiveIsObject, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "parse-word",ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "sfind", ficlPrimitiveSFind, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "sliteral", ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "sprintf", ficlPrimitiveSprintf, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "strlen", ficlPrimitiveStrlen, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "x.", ficlPrimitiveHexDot, FICL_WORD_DEFAULT);
+#if FICL_WANT_USER
+ ficlDictionarySetPrimitive(dictionary, "user", ficlPrimitiveUser, FICL_WORD_DEFAULT);
+#endif
+
+ /*
+ ** internal support words
+ */
+ interpret =
+ ficlDictionarySetPrimitive(dictionary, "interpret", ficlPrimitiveInterpret, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "lookup", ficlPrimitiveLookup, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "(parse-step)",
+ ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
+ system->exitInnerWord =
+ ficlDictionarySetPrimitive(dictionary, "exit-inner",ficlPrimitiveExitInner, FICL_WORD_DEFAULT);
+
+ /*
+ ** Set constants representing the internal instruction words
+ ** If you want all of 'em, turn that "#if 0" to "#if 1".
+ ** By default you only get the numbers (fi0, fiNeg1, etc).
+ */
+ #define FICL_TOKEN(token, description) ficlDictionarySetConstant(dictionary, #token, token);
+#if 0
+ #define FICL_INSTRUCTION_TOKEN(token, description, flags) ficlDictionarySetConstant(dictionary, #token, token);
+#else
+ #define FICL_INSTRUCTION_TOKEN(token, description, flags)
+#endif /* 0 */
+ #include "ficltokens.h"
+ #undef FICL_TOKEN
+ #undef FICL_INSTRUCTION_TOKEN
+
+
+ /*
+ ** Set up system's outer interpreter loop - maybe this should be in initSystem?
+ */
+ system->interpreterLoop[0] = interpret;
+ system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen;
+ system->interpreterLoop[2] = (ficlWord *)(void *)(-2);
+
+ FICL_SYSTEM_ASSERT(system, ficlDictionaryCellsAvailable(dictionary) > 0);
+
+ return;
+}
+
diff --git a/search.c b/search.c
index 74ea37569e77..c5c9a7084ad2 100644
--- 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 01:24:34-07 jsadler Exp jsadler $
+** $Id: search.c,v 1.10 2010/08/12 13:57:22 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -12,9 +12,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -43,7 +43,6 @@
#include <string.h>
#include "ficl.h"
-#include "math64.h"
/**************************************************************************
d e f i n i t i o n s
@@ -53,17 +52,17 @@
** be placed in the compilation word list. Subsequent changes in the search
** order will not affect the compilation word list.
**************************************************************************/
-static void definitions(FICL_VM *pVM)
+static void ficlPrimitiveDefinitions(ficlVm *vm)
{
- FICL_DICT *pDict = vmGetDict(pVM);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
- assert(pDict);
- if (pDict->nLists < 1)
+ FICL_VM_ASSERT(vm, dictionary);
+ if (dictionary->wordlistCount < 1)
{
- vmThrowErr(pVM, "DEFINITIONS error - empty search order");
+ ficlVmThrowError(vm, "DEFINITIONS error - empty search order");
}
- pDict->pCompile = pDict->pSearch[pDict->nLists-1];
+ dictionary->compilationWordlist = dictionary->wordlists[dictionary->wordlistCount-1];
return;
}
@@ -75,10 +74,10 @@ static void definitions(FICL_VM *pVM)
** words provided by the implementation. This word list is initially the
** compilation word list and is part of the initial search order.
**************************************************************************/
-static void forthWordlist(FICL_VM *pVM)
+static void ficlPrimitiveForthWordlist(ficlVm *vm)
{
- FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
- stackPushPtr(pVM->pStack, pHash);
+ ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
+ ficlStackPushPointer(vm->dataStack, hash);
return;
}
@@ -88,11 +87,12 @@ static void forthWordlist(FICL_VM *pVM)
** SEARCH ( -- wid )
** Return wid, the identifier of the compilation word list.
**************************************************************************/
-static void getCurrent(FICL_VM *pVM)
+static void ficlPrimitiveGetCurrent(ficlVm *vm)
{
- ficlLockDictionary(TRUE);
- stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile);
- ficlLockDictionary(FALSE);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ ficlStackPushPointer(vm->dataStack, dictionary->compilationWordlist);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
@@ -105,20 +105,20 @@ static void getCurrent(FICL_VM *pVM)
** the word list that is searched first, and widn the word list that is
** searched last. The search order is unaffected.
**************************************************************************/
-static void getOrder(FICL_VM *pVM)
+static void ficlPrimitiveGetOrder(ficlVm *vm)
{
- FICL_DICT *pDict = vmGetDict(pVM);
- int nLists = pDict->nLists;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ int wordlistCount = dictionary->wordlistCount;
int i;
- ficlLockDictionary(TRUE);
- for (i = 0; i < nLists; i++)
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ for (i = 0; i < wordlistCount; i++)
{
- stackPushPtr(pVM->pStack, pDict->pSearch[i]);
+ ficlStackPushPointer(vm->dataStack, dictionary->wordlists[i]);
}
- stackPushUNS(pVM->pStack, nLists);
- ficlLockDictionary(FALSE);
+ ficlStackPushUnsigned(vm->dataStack, wordlistCount);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
@@ -131,29 +131,29 @@ static void getOrder(FICL_VM *pVM)
** definition is found, return its execution token xt and one (1) if the
** definition is immediate, minus-one (-1) otherwise.
**************************************************************************/
-static void searchWordlist(FICL_VM *pVM)
+static void ficlPrimitiveSearchWordlist(ficlVm *vm)
{
- STRINGINFO si;
- UNS16 hashCode;
- FICL_WORD *pFW;
- FICL_HASH *pHash = stackPopPtr(pVM->pStack);
+ ficlString name;
+ ficlUnsigned16 hashCode;
+ ficlWord *word;
+ ficlHash *hash = ficlStackPopPointer(vm->dataStack);
- si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
- si.cp = stackPopPtr(pVM->pStack);
- hashCode = hashHashCode(si);
+ name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack);
+ name.text = ficlStackPopPointer(vm->dataStack);
+ hashCode = ficlHashCode(name);
- ficlLockDictionary(TRUE);
- pFW = hashLookup(pHash, si, hashCode);
- ficlLockDictionary(FALSE);
+ ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE);
+ word = ficlHashLookup(hash, name, hashCode);
+ ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE);
- if (pFW)
+ if (word)
{
- stackPushPtr(pVM->pStack, pFW);
- stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
+ ficlStackPushPointer(vm->dataStack, word);
+ ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1));
}
else
{
- stackPushUNS(pVM->pStack, 0);
+ ficlStackPushUnsigned(vm->dataStack, 0);
}
return;
@@ -165,13 +165,13 @@ static void searchWordlist(FICL_VM *pVM)
** SEARCH ( wid -- )
** Set the compilation word list to the word list identified by wid.
**************************************************************************/
-static void setCurrent(FICL_VM *pVM)
+static void ficlPrimitiveSetCurrent(ficlVm *vm)
{
- FICL_HASH *pHash = stackPopPtr(pVM->pStack);
- FICL_DICT *pDict = vmGetDict(pVM);
- ficlLockDictionary(TRUE);
- pDict->pCompile = pHash;
- ficlLockDictionary(FALSE);
+ ficlHash *hash = ficlStackPopPointer(vm->dataStack);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ dictionary->compilationWordlist = hash;
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
@@ -187,33 +187,33 @@ static void setCurrent(FICL_VM *pVM)
** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
** be at least eight.
**************************************************************************/
-static void setOrder(FICL_VM *pVM)
+static void ficlPrimitiveSetOrder(ficlVm *vm)
{
int i;
- int nLists = stackPopINT(pVM->pStack);
- FICL_DICT *dp = vmGetDict(pVM);
+ int wordlistCount = ficlStackPopInteger(vm->dataStack);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
- if (nLists > FICL_DEFAULT_VOCS)
+ if (wordlistCount > FICL_MAX_WORDLISTS)
{
- vmThrowErr(pVM, "set-order error: list would be too large");
+ ficlVmThrowError(vm, "set-order error: list would be too large");
}
- ficlLockDictionary(TRUE);
+ ficlDictionaryLock(dictionary, FICL_TRUE);
- if (nLists >= 0)
+ if (wordlistCount >= 0)
{
- dp->nLists = nLists;
- for (i = nLists-1; i >= 0; --i)
+ dictionary->wordlistCount = wordlistCount;
+ for (i = wordlistCount-1; i >= 0; --i)
{
- dp->pSearch[i] = stackPopPtr(pVM->pStack);
+ dictionary->wordlists[i] = ficlStackPopPointer(vm->dataStack);
}
}
else
{
- dictResetSearchOrder(dp);
+ ficlDictionaryResetSearchOrder(dictionary);
}
- ficlLockDictionary(FALSE);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
@@ -227,118 +227,122 @@ static void setOrder(FICL_VM *pVM)
** allow the creation of at least 8 new word lists in addition to any
** provided as part of the system.
** Notes:
-** 1. ficl creates a new single-list hash in the dictionary and returns
+** 1. Ficl creates a new single-list hash in the dictionary and returns
** its address.
** 2. ficl-wordlist takes an arg off the stack indicating the number of
** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
** : wordlist 1 ficl-wordlist ;
**************************************************************************/
-static void ficlWordlist(FICL_VM *pVM)
+static void ficlPrimitiveFiclWordlist(ficlVm *vm)
{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_HASH *pHash;
- FICL_UNS nBuckets;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash;
+ ficlUnsigned nBuckets;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- nBuckets = stackPopUNS(pVM->pStack);
- pHash = dictCreateWordlist(dp, nBuckets);
- stackPushPtr(pVM->pStack, pHash);
+ FICL_STACK_CHECK(vm->dataStack, 1, 1);
+
+ nBuckets = ficlStackPopUnsigned(vm->dataStack);
+ hash = ficlDictionaryCreateWordlist(dictionary, nBuckets);
+ ficlStackPushPointer(vm->dataStack, hash);
return;
}
/**************************************************************************
S E A R C H >
-** ficl ( -- wid )
+** Ficl ( -- wid )
** Pop wid off the search order. Error if the search order is empty
**************************************************************************/
-static void searchPop(FICL_VM *pVM)
+static void ficlPrimitiveSearchPop(ficlVm *vm)
{
- FICL_DICT *dp = vmGetDict(pVM);
- int nLists;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ int wordlistCount;
- ficlLockDictionary(TRUE);
- nLists = dp->nLists;
- if (nLists == 0)
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ wordlistCount = dictionary->wordlistCount;
+ if (wordlistCount == 0)
{
- vmThrowErr(pVM, "search> error: empty search order");
+ ficlVmThrowError(vm, "search> error: empty search order");
}
- stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
- ficlLockDictionary(FALSE);
+ ficlStackPushPointer(vm->dataStack, dictionary->wordlists[--dictionary->wordlistCount]);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
> S E A R C H
-** ficl ( wid -- )
+** Ficl ( wid -- )
** Push wid onto the search order. Error if the search order is full.
**************************************************************************/
-static void searchPush(FICL_VM *pVM)
+static void ficlPrimitiveSearchPush(ficlVm *vm)
{
- FICL_DICT *dp = vmGetDict(pVM);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
- ficlLockDictionary(TRUE);
- if (dp->nLists > FICL_DEFAULT_VOCS)
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ if (dictionary->wordlistCount > FICL_MAX_WORDLISTS)
{
- vmThrowErr(pVM, ">search error: search order overflow");
+ ficlVmThrowError(vm, ">search error: search order overflow");
}
- dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
- ficlLockDictionary(FALSE);
+ dictionary->wordlists[dictionary->wordlistCount++] = ficlStackPopPointer(vm->dataStack);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
W I D - G E T - N A M E
-** ficl ( wid -- c-addr u )
+** Ficl ( wid -- c-addr u )
** Get wid's (optional) name and push onto stack as a counted string
**************************************************************************/
-static void widGetName(FICL_VM *pVM)
+static void ficlPrimitiveWidGetName(ficlVm *vm)
{
- FICL_HASH *pHash = vmPop(pVM).p;
- char *cp = pHash->name;
- FICL_INT len = 0;
+ ficlHash *hash;
+ char *name;
+ ficlInteger length;
+
+ hash = ficlVmPop(vm).p;
+ name = hash->name;
- if (cp)
- len = strlen(cp);
+ if (name != NULL)
+ length = strlen(name);
+ else
+ length = 0;
- vmPush(pVM, LVALUEtoCELL(cp));
- vmPush(pVM, LVALUEtoCELL(len));
+ ficlVmPush(vm, FICL_LVALUE_TO_CELL(name));
+ ficlVmPush(vm, FICL_LVALUE_TO_CELL(length));
return;
}
/**************************************************************************
W I D - S E T - N A M E
-** ficl ( wid c-addr -- )
+** Ficl ( wid c-addr -- )
** Set wid's name pointer to the \0 terminated string address supplied
**************************************************************************/
-static void widSetName(FICL_VM *pVM)
+static void ficlPrimitiveWidSetName(ficlVm *vm)
{
- char *cp = (char *)vmPop(pVM).p;
- FICL_HASH *pHash = vmPop(pVM).p;
- pHash->name = cp;
+ char *name = (char *)ficlVmPop(vm).p;
+ ficlHash *hash = ficlVmPop(vm).p;
+ hash->name = name;
return;
}
/**************************************************************************
setParentWid
-** FICL
+** Ficl
** setparentwid ( parent-wid wid -- )
** Set WID's link field to the parent-wid. search-wordlist will
** iterate through all the links when finding words in the child wid.
**************************************************************************/
-static void setParentWid(FICL_VM *pVM)
+static void ficlPrimitiveSetParentWid(ficlVm *vm)
{
- FICL_HASH *parent, *child;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- child = (FICL_HASH *)stackPopPtr(pVM->pStack);
- parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
+ ficlHash *parent, *child;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ child = (ficlHash *)ficlStackPopPointer(vm->dataStack);
+ parent = (ficlHash *)ficlStackPopPointer(vm->dataStack);
child->link = parent;
return;
@@ -350,42 +354,46 @@ static void setParentWid(FICL_VM *pVM)
** Builds the primitive wordset and the environment-query namespace.
**************************************************************************/
-void ficlCompileSearch(FICL_SYSTEM *pSys)
+void ficlSystemCompileSearch(ficlSystem *system)
{
- FICL_DICT *dp = pSys->dp;
- assert (dp);
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
/*
** optional SEARCH-ORDER word set
*/
- dictAppendWord(dp, ">search", searchPush, FW_DEFAULT);
- dictAppendWord(dp, "search>", searchPop, FW_DEFAULT);
- dictAppendWord(dp, "definitions",
- definitions, FW_DEFAULT);
- dictAppendWord(dp, "forth-wordlist",
- forthWordlist, FW_DEFAULT);
- dictAppendWord(dp, "get-current",
- getCurrent, FW_DEFAULT);
- dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT);
- dictAppendWord(dp, "search-wordlist",
- searchWordlist, FW_DEFAULT);
- dictAppendWord(dp, "set-current",
- setCurrent, FW_DEFAULT);
- dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
- dictAppendWord(dp, "ficl-wordlist",
- ficlWordlist, FW_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ">search", ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "search>", ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "definitions",
+ ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
+ ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "get-current",
+ ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "get-order", ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "search-wordlist",
+ ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "set-current",
+ ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "set-order", ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
+ ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);
/*
** Set SEARCH environment query values
*/
- ficlSetEnv(pSys, "search-order", FICL_TRUE);
- ficlSetEnv(pSys, "search-order-ext", FICL_TRUE);
- ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS);
-
- dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT);
- dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT);
- dictAppendWord(dp, "wid-set-super",
- setParentWid, FW_DEFAULT);
+ ficlDictionarySetConstant(environment, "search-order", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "search-order-ext", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "wordlists", FICL_MAX_WORDLISTS);
+
+ ficlDictionarySetPrimitive(dictionary, "wid-get-name", ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "wid-set-name", ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "wid-set-super",
+ ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
return;
}
diff --git a/softcore.c b/softcore.c
index 2e38728a49a9..af614f6a0f88 100644
--- a/softcore.c
+++ b/softcore.c
@@ -1,1028 +1,2551 @@
-/*******************************************************************
-** 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: Thu Jun 13 02:57:00 2002
-*******************************************************************/
/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.py
-** 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.py
-*/
-/*
-** 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.
+** Ficl softcore
+** both uncompressed and Lempel-Ziv compressed versions.
**
-** 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.
-*/
-
+** Generated 2003/05/05 12:42:30
+**/
#include "ficl.h"
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS
-/*
-** ficl/softwords/softcore.fr
-** FICL soft extensions
-** John Sadler (john_sadler@alum.mit.edu)
-** September, 1998
-*/
-/*
-** Ficl USER variables
-** See words.c for primitive def'n of USER
-*/
- ".( loading ficl soft extensions ) cr "
-#if FICL_WANT_USER
- "variable nUser 0 nUser ! "
- ": user "
- "nUser dup @ user 1 swap +! ; "
-#endif
-/*
-** ficl extras
-*/
- ": empty depth 0 ?do drop loop ; "
- ": cell- [ 1 cells ] literal - ; "
- ": -rot 2 -roll ; "
-/*
-** CORE
-*/
- ": abs "
- "dup 0< if negate endif ; "
- "decimal 32 constant bl "
- ": space bl emit ; "
- ": spaces 0 ?do space loop ; "
- ": abort\" "
- "state @ if "
- "postpone if "
- "postpone .\" "
- "postpone cr "
- "-2 "
- "postpone literal "
- "postpone throw "
- "postpone endif "
- "else "
- "[char] \" parse "
- "rot if "
- "type "
- "cr "
- "-2 throw "
- "else "
- "2drop "
- "endif "
- "endif "
- "; immediate "
-/*
-** CORE EXT
-*/
- ".( loading CORE EXT words ) cr "
- "0 constant false "
- "false invert constant true "
- ": <> = 0= ; "
- ": 0<> 0= 0= ; "
- ": compile, , ; "
- ": convert char+ 65535 >number drop ; "
- ": erase 0 fill ; "
- "variable span "
- ": expect accept span ! ; "
- ": nip swap drop ; "
- ": tuck swap over ; "
- ": within over - >r - r> u< ; "
-/*
-** LOCAL EXT word set
-*/
-#if FICL_WANT_LOCALS
- ": locals| "
- "begin "
- "bl word count "
- "dup 0= abort\" where's the delimiter??\" "
- "over c@ "
- "[char] | - over 1- or "
- "while "
- "(local) "
- "repeat 2drop 0 0 (local) "
- "; immediate "
- ": local bl word count (local) ; immediate "
- ": 2local bl word count (2local) ; immediate "
- ": end-locals 0 0 (local) ; immediate "
-#endif
-/*
-** TOOLS word set...
-*/
- ": ? @ . ; "
- ": dump "
- "0 ?do "
- "dup c@ . 1+ "
- "i 7 and 7 = if cr endif "
- "loop drop "
- "; "
-/*
-** SEARCH+EXT words and ficl helpers
-*/
- ".( loading SEARCH & SEARCH-EXT words ) cr "
- ": brand-wordlist last-word >name drop wid-set-name ; "
- ": ficl-named-wordlist "
- "ficl-wordlist dup create , brand-wordlist does> @ ; "
- ": wordlist "
- "1 ficl-wordlist ; "
- ": ficl-set-current "
- "get-current swap set-current ; "
- ": do-vocabulary "
- "does> @ search> drop >search ; "
- ": ficl-vocabulary "
- "ficl-named-wordlist do-vocabulary ; "
- ": vocabulary "
- "1 ficl-vocabulary ; "
- ": previous search> drop ; "
- "1 ficl-named-wordlist hidden "
- ": hide hidden dup >search ficl-set-current ; "
- ": also "
- "search> dup >search >search ; "
- ": forth "
- "search> drop "
- "forth-wordlist >search ; "
- ": only "
- "-1 set-order ; "
- "hide "
- ": list-wid "
- "dup wid-get-name "
- "?dup if "
- "type drop "
- "else "
- "drop .\" (unnamed wid) \" x. "
- "endif cr "
- "; "
- "set-current "
- ": order "
- ".\" Search:\" cr "
- "get-order 0 ?do 3 spaces list-wid loop cr "
- ".\" Compile: \" get-current list-wid cr "
- "; "
- ": debug ' debug-xt ; immediate "
- ": 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
-*/
-#if FICL_WANT_LOCALS
-/*
-** ficl/softwords/jhlocal.fr
-** stack comment style local syntax...
-*/
- ".( loading Johns-Hopkins locals ) cr "
- "hide "
- "0 constant zero "
- ": ?-- "
- "2dup s\" --\" compare 0= ; "
- ": ?} "
- "2dup s\" }\" compare 0= ; "
- ": ?| "
- "2dup s\" |\" compare 0= ; "
- ": ?2loc "
- "over dup c@ [char] 2 = "
- "swap 1+ c@ [char] : = and "
- "if "
- "2 - swap char+ char+ swap "
- "true "
- "else "
- "false "
- "endif "
- "; "
- ": ?delim "
- "?| if 2drop 1 exit endif "
- "?-- if 2drop 2 exit endif "
- "?} if 2drop 3 exit endif "
- "dup 0= "
- "if 2drop 4 exit endif "
- "0 "
- "; "
- "set-current "
- ": { "
- "0 dup locals| locstate | "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "0= while "
- "rot 1+ "
- "repeat "
- "0 ?do "
- "?2loc if (2local) else (local) endif "
- "loop "
- "locstate 1 = if "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "0= while "
- "?2loc if "
- "postpone zero postpone zero (2local) "
- "else "
- "postpone zero (local) "
- "endif "
- "repeat "
- "endif "
- "0 0 (local) "
- "locstate 2 = if "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "3 < while "
- "locstate 0= if 2drop endif "
- "repeat "
- "endif "
- "locstate 3 <> abort\" syntax error in { } local line\" "
- "; immediate compile-only "
- "previous "
-#endif
-/*
-** ficl/softwords/marker.fr
-** Ficl implementation of CORE EXT MARKER
-*/
- ".( loading MARKER ) cr "
- ": marker "
- "create "
- "get-current , "
- "get-order dup , "
- "0 ?do , loop "
- "does> "
- "0 set-order "
- "dup body> >name drop "
- "here - allot "
- "dup @ "
- "dup set-current forget-wid "
- "cell+ dup @ swap "
- "over cells + swap "
- "0 ?do "
- "dup @ dup "
- ">search forget-wid "
- "cell- "
- "loop "
- "drop "
- "; "
-/*
-**
-** Prefix words for ficl
-** submitted by Larry Hastings, larry@hastings.org
-**
-*/
- "variable save-current "
- ": start-prefixes get-current save-current ! <prefixes> set-current ; "
- ": end-prefixes save-current @ set-current ; "
- ": show-prefixes <prefixes> >search words search> drop ; "
-#if (FICL_EXTENDED_PREFIX)
- "start-prefixes "
- ": \" postpone s\" ; immediate "
- ": .( postpone .( ; immediate "
-/*
-** add 0b, 0o, 0d, and 0x as prefixes
-** these temporarily shift the base to 2, 8, 10, and 16 respectively
-** and consume the next number in the input stream, pushing/compiling
-** as normal
-*/
- ": 0b 2 __tempbase ; immediate "
- ": 0o 8 __tempbase ; immediate "
- "end-prefixes "
-#endif
-/*
-** ficl/softwords/ifbrack.fr
-** ANS conditional compile directives [if] [else] [then]
-** Requires ficl 2.0 or greater...
-*/
- "hide "
- ": ?[if] "
- "2dup s\" [if]\" compare-insensitive 0= "
- "; "
- ": ?[else] "
- "2dup s\" [else]\" compare-insensitive 0= "
- "; "
- ": ?[then] "
- "2dup s\" [then]\" compare-insensitive 0= >r "
- "2dup s\" [endif]\" compare-insensitive 0= r> "
- "or "
- "; "
- "set-current "
- ": [else] "
- "1 "
- "begin "
- "begin "
- "parse-word dup while "
- "?[if] if "
- "2drop 1+ "
- "else "
- "?[else] if "
- "2drop 1- dup if 1+ endif "
- "else "
- "?[then] if 2drop 1- else 2drop endif "
- "endif "
- "endif ?dup 0= if exit endif "
- "repeat 2drop "
- "refill 0= until "
- "drop "
- "; immediate "
- ": [if] "
- "0= if postpone [else] then ; immediate "
- ": [then] ; immediate "
- ": [endif] ; immediate "
- "previous "
-#if FICL_WANT_OOP
-/*
-** ficl/softwords/oo.fr
-** F I C L O - O E X T E N S I O N S
-** john sadler aug 1998
-*/
- ".( loading ficl O-O extensions ) cr "
- "17 ficl-vocabulary oop "
- "also oop definitions "
- "user current-class "
- "0 current-class ! "
-/*
-** L A T E B I N D I N G
-*/
- ": parse-method "
- "parse-word "
- "postpone sliteral "
- "; compile-only "
- ": (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 } "
- "class name class cell+ @ "
- "search-wordlist "
- "; "
- ": lookup-method { class 2:name -- class xt } "
- "class name (lookup-method) "
- "0= if "
- "name type .\" not found in \" "
- "class body> >name type "
- "cr abort "
- "endif "
- "; "
- ": find-method-xt "
- "parse-word lookup-method "
- "; "
- ": catch-method "
- "lookup-method catch "
- "; "
- ": exec-method "
- "lookup-method execute "
- "; "
- ": --> "
- "state @ 0= if "
- "find-method-xt execute "
- "else "
- "parse-method postpone exec-method "
- "endif "
- "; immediate "
- ": c-> "
- "state @ 0= if "
- "find-method-xt catch "
- "else "
- "parse-method postpone catch-method "
- "endif "
- "; immediate "
- ": method create does> body> >name lookup-method execute ; "
-/*
-** E A R L Y B I N D I N G
-*/
- "1 ficl-named-wordlist instance-vars "
- "instance-vars dup >search ficl-set-current "
- ": => "
- "drop find-method-xt compile, drop "
- "; immediate compile-only "
- ": my=> "
- "current-class @ dup postpone => "
- "; immediate compile-only "
- ": my=[ "
- "current-class @ "
- "begin "
- "parse-word 2dup "
- "s\" ]\" compare while "
- "lookup-method "
- "dup compile, "
- "dup ?object if "
- "nip >body cell+ @ "
- "else "
- "drop "
- "endif "
- "repeat 2drop drop "
- "; immediate compile-only "
-/*
-** I N S T A N C E V A R I A B L E S
-*/
- ": do-instance-var "
- "does> "
- "nip @ + "
- "; "
- ": addr-units: "
- "create over , + "
- "do-instance-var "
- "; "
- ": chars: "
- "chars addr-units: ; "
- ": char: "
- "1 chars: ; "
- ": cells: "
- "cells >r aligned r> addr-units: "
- "; "
- ": cell: "
- "1 cells: ; "
- ": do-aggregate "
- "objectify "
- "does> "
- "2@ "
- "2swap drop "
- "+ swap "
- "; "
- ": obj: { offset class meta -- offset' } "
- "create offset , class , "
- "class meta --> get-size offset + "
- "do-aggregate "
- "; "
- ": array: "
- "locals| meta class nobjs offset | "
- "create offset , class , "
- "class meta --> get-size nobjs * offset + "
- "do-aggregate "
- "; "
- ": ref: "
- "locals| meta class offset | "
- "create offset , class , "
- "offset cell+ "
- "does> "
- "2@ "
- "2swap drop + @ swap "
- "; "
-#if FICL_WANT_VCALL
- ": vcall: "
- "current-class @ 8 + dup @ dup 1+ rot ! "
- "create , , "
- "does> "
- "nip 2@ vcall "
- "; "
- ": vcallr: 0x80000000 or vcall: ; "
-#if FICL_WANT_FLOAT
- ": vcallf: "
- "0x80000000 or "
- "current-class @ 8 + dup @ dup 1+ rot ! "
- "create , , "
- "does> "
- "nip 2@ vcall f> "
- "; "
-#endif /* FLOAT */
-#endif /* VCALL */
- ": end-class "
- "swap ! set-current "
- "search> drop "
- "; "
- ": suspend-class end-class ; "
- "set-current previous "
- ": do-do-instance "
- "s\" : .do-instance does> [ current-class @ ] literal ;\" "
- "evaluate "
- "; "
-/*
-** M E T A C L A S S
-*/
- ":noname "
- "wordlist "
- "create "
- "immediate "
- "0 , "
- "dup , "
-#if FICL_WANT_VCALL
- "4 cells , "
-#else
- "3 cells , "
-#endif
- "ficl-set-current "
- "does> dup "
- "; execute metaclass "
- "metaclass drop cell+ @ brand-wordlist "
- "metaclass drop current-class ! "
- "do-do-instance "
- "instance-vars >search "
- "create .super "
- "0 cells , do-instance-var "
- "create .wid "
- "1 cells , do-instance-var "
-#if FICL_WANT_VCALL
- "create .vtCount "
- "2 cells , do-instance-var "
- "create .size "
- "3 cells , do-instance-var "
-#else
- "create .size "
- "2 cells , do-instance-var "
-#endif
- ": get-size metaclass => .size @ ; "
- ": get-wid metaclass => .wid @ ; "
- ": get-super metaclass => .super @ ; "
-#if FICL_WANT_VCALL
- ": get-vtCount metaclass => .vtCount @ ; "
- ": get-vtAdd metaclass => .vtCount ; "
-#endif
- ": instance "
- "locals| meta parent | "
- "create "
- "here parent --> .do-instance "
- "parent meta metaclass => get-size "
- "allot "
- "; "
- ": array "
- "locals| meta parent nobj | "
- "create nobj "
- "here parent --> .do-instance "
- "parent meta metaclass => get-size "
- "nobj * allot "
- "; "
- ": new "
- "metaclass => instance --> init "
- "; "
- ": new-array "
- "metaclass => array "
- "--> array-init "
- "; "
- ": alloc "
- "locals| meta class | "
- "class meta metaclass => get-size allocate "
- "abort\" allocate failed \" "
- "class 2dup --> init "
- "; "
- ": alloc-array "
- "locals| meta class nobj | "
- "class meta metaclass => get-size "
- "nobj * allocate "
- "abort\" allocate failed \" "
- "nobj over class --> array-init "
- "class "
- "; "
- ": allot { 2:this -- 2:instance } "
- "here "
- "this my=> get-size allot "
- "this drop 2dup --> init "
- "; "
- ": allot-array { nobj 2:this -- 2:instance } "
- "here "
- "this my=> get-size nobj * allot "
- "this drop 2dup "
- "nobj -rot --> array-init "
- "; "
- ": ref "
- "drop create , , "
- "does> 2@ "
- "; "
- ": resume-class { 2:this -- old-wid addr[size] size } "
- "this --> .wid @ ficl-set-current "
- "this --> .size dup @ "
- "instance-vars >search "
- "; "
- ": sub "
- "wordlist "
- "locals| wid meta parent | "
- "parent meta metaclass => get-wid "
- "wid wid-set-super "
- "create immediate "
- "wid brand-wordlist "
- "here current-class ! "
- "parent , "
- "wid , "
-#if FICL_WANT_VCALL
- "parent meta --> get-vtCount , "
-#endif
- "here parent meta --> get-size dup , "
- "metaclass => .do-instance "
- "wid ficl-set-current -rot "
- "do-do-instance "
- "instance-vars >search "
- "; "
- ": offset-of "
- "drop find-method-xt nip >body @ ; "
- ": id "
- "drop body> >name ; "
- ": methods "
- "locals| meta class | "
- "begin "
- "class body> >name type .\" methods:\" cr "
- "class meta --> get-wid >search words cr previous "
- "class meta metaclass => get-super "
- "dup to class "
- "0= until cr "
- "; "
- ": pedigree "
- "locals| meta class | "
- "begin "
- "class body> >name type space "
- "class meta metaclass => get-super "
- "dup to class "
- "0= until cr "
- "; "
- ": see "
- "metaclass => get-wid >search see previous ; "
- ": debug "
- "find-method-xt debug-xt ; "
- "previous set-current "
-/*
-** META is a nickname for the address of METACLASS...
-*/
- "metaclass drop "
- "constant meta "
-/*
-** SUBCLASS is a nickname for a class's SUB method...
-*/
- ": subclass --> sub ; "
-#if FICL_WANT_VCALL
- ": hasvtable 4 + ; immediate "
-#endif
-/*
-** O B J E C T
-*/
- ":noname "
- "wordlist "
- "create immediate "
- "0 , "
- "dup , "
- "0 , "
- "ficl-set-current "
- "does> meta "
- "; execute object "
- "object drop cell+ @ brand-wordlist "
- "object drop current-class ! "
- "do-do-instance "
- "instance-vars >search "
- ": class "
- "nip meta ; "
- ": init "
- "meta "
- "metaclass => get-size "
- "erase ; "
- ": array-init "
- "0 dup locals| &init &next class inst | "
- "class s\" init\" lookup-method to &init "
- "s\" next\" lookup-method to &next "
- "drop "
- "0 ?do "
- "inst class 2dup "
- "&init execute "
- "&next execute drop to inst "
- "loop "
- "; "
- ": free "
- "drop free "
- "abort\" free failed \" "
- "; "
- ": super "
- "meta metaclass => get-super ; "
- ": pedigree "
- "object => class "
- "metaclass => pedigree ; "
- ": size "
- "object => class "
- "metaclass => get-size ; "
- ": methods "
- "object => class "
- "metaclass => methods ; "
- ": index "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size * "
- "inst + class ; "
- ": next "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size "
- "inst + "
- "class ; "
- ": prev "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size "
- "inst swap - "
- "class ; "
- ": debug "
- "find-method-xt debug-xt ; "
- "previous set-current "
- "only definitions "
- ": oo only also oop definitions ; "
-#endif
-#if (FICL_WANT_OOP)
-/*
-** ficl/softwords/classes.fr
-** F I C L 2 . 0 C L A S S E S
-*/
- ".( loading ficl utility classes ) cr "
- "also oop definitions "
- "object subclass c-ref "
- "cell: .class "
- "cell: .instance "
- ": get "
- "drop 2@ ; "
- ": set "
- "drop 2! ; "
- "end-class "
- "object subclass c-byte "
- "char: .payload "
- ": get drop c@ ; "
- ": set drop c! ; "
- "end-class "
- "object subclass c-2byte "
- "2 chars: .payload "
- ": get drop w@ ; "
- ": set drop w! ; "
- "end-class "
- "object subclass c-4byte "
- "4 chars: .payload "
- ": get drop q@ ; "
- ": set drop q! ; "
- "end-class "
- "object subclass c-cell "
- "cell: .payload "
- ": get drop @ ; "
- ": set drop ! ; "
- "end-class "
-/*
-** C - P T R
-*/
- "object subclass c-ptr "
- "c-cell obj: .addr "
- ": get-ptr "
- "c-ptr => .addr "
- "c-cell => get "
- "; "
- ": set-ptr "
- "c-ptr => .addr "
- "c-cell => set "
- "; "
- ": clr-ptr "
- "0 -rot c-ptr => .addr c-cell => set "
- "; "
- ": ?null "
- "c-ptr => get-ptr 0= "
- "; "
- ": inc-ptr "
- "2dup 2dup "
- "c-ptr => get-ptr -rot "
- "--> @size + -rot "
- "c-ptr => set-ptr "
- "; "
- ": dec-ptr "
- "2dup 2dup "
- "c-ptr => get-ptr -rot "
- "--> @size - -rot "
- "c-ptr => set-ptr "
- "; "
- ": index-ptr { index 2:this -- } "
- "this --> get-ptr "
- "this --> @size index * + "
- "this --> set-ptr "
- "; "
- "end-class "
-/*
-** C - C E L L P T R
-*/
- "c-ptr subclass c-cellPtr "
- ": @size 2drop 1 cells ; "
- ": get "
- "c-ptr => get-ptr @ "
- "; "
- ": set "
- "c-ptr => get-ptr ! "
- "; "
- "end-class "
-/*
-** C - 4 B Y T E P T R
-*/
- "c-ptr subclass c-4bytePtr "
- ": @size 2drop 4 ; "
- ": get "
- "c-ptr => get-ptr q@ "
- "; "
- ": set "
- "c-ptr => get-ptr q! "
- "; "
- "end-class "
-/*
-** C - 2 B Y T E P T R
-*/
- "c-ptr subclass c-2bytePtr "
- ": @size 2drop 2 ; "
- ": get "
- "c-ptr => get-ptr w@ "
- "; "
- ": set "
- "c-ptr => get-ptr w! "
- "; "
- "end-class "
-/*
-** C - B Y T E P T R
-*/
- "c-ptr subclass c-bytePtr "
- ": @size 2drop 1 ; "
- ": get "
- "c-ptr => get-ptr c@ "
- "; "
- ": set "
- "c-ptr => get-ptr c! "
- "; "
- "end-class "
- "previous definitions "
-#endif
-#if (FICL_WANT_OOP)
-/*
-** ficl/softwords/string.fr
-*/
-/*
-** C - S T R I N G
-*/
- ".( loading ficl string class ) cr "
- "also oop definitions "
- "object subclass c-string "
- "c-cell obj: .count "
- "c-cell obj: .buflen "
- "c-ptr obj: .buf "
- "32 constant min-buf "
- ": get-count my=[ .count get ] ; "
- ": set-count my=[ .count set ] ; "
- ": ?empty --> get-count 0= ; "
- ": get-buflen my=[ .buflen get ] ; "
- ": set-buflen my=[ .buflen set ] ; "
- ": get-buf my=[ .buf get-ptr ] ; "
- ": set-buf { ptr len 2:this -- } "
- "ptr this my=[ .buf set-ptr ] "
- "len this my=> set-buflen "
- "; "
- ": clr-buf "
- "0 0 2over my=> set-buf "
- "0 -rot my=> set-count "
- "; "
- ": free-buf { 2:this -- } "
- "this my=> get-buf "
- "?dup if "
- "free "
- "abort\" c-string free failed\" "
- "this my=> clr-buf "
- "endif "
- "; "
- ": size-buf { size 2:this -- } "
- "size 0< abort\" need positive size for size-buf\" "
- "size 0= if "
- "this --> free-buf exit "
- "endif "
- "my=> min-buf size over / 1+ * chars to size "
- "this --> get-buflen 0= "
- "if "
- "size allocate "
- "abort\" out of memory\" "
- "size this --> set-buf "
- "size this --> set-buflen "
- "exit "
- "endif "
- "size this --> get-buflen > if "
- "this --> get-buf size resize "
- "abort\" out of memory\" "
- "size this --> set-buf "
- "endif "
- "; "
- ": set { c-addr u 2:this -- } "
- "u this --> size-buf "
- "u this --> set-count "
- "c-addr this --> get-buf u move "
- "; "
- ": get { 2:this -- c-addr u } "
- "this --> get-buf "
- "this --> get-count "
- "; "
- ": cat { c-addr u 2:this -- } "
- "this --> get-count u + dup >r "
- "this --> size-buf "
- "c-addr this --> get-buf this --> get-count + u move "
- "r> this --> set-count "
- "; "
- ": type { 2:this -- } "
- "this --> ?empty if .\" (empty) \" exit endif "
- "this --> .buf --> get-ptr "
- "this --> .count --> get "
- "type "
- "; "
- ": compare "
- "--> get "
- "2swap "
- "--> get "
- "2swap compare "
- "; "
- ": hashcode "
- "--> get hash "
- "; "
- ": free 2dup --> free-buf object => free ; "
- "end-class "
- "c-string subclass c-hashstring "
- "c-2byte obj: .hashcode "
- ": set-hashcode { 2:this -- } "
- "this --> super --> hashcode "
- "this --> .hashcode --> set "
- "; "
- ": get-hashcode "
- "--> .hashcode --> get "
- "; "
- ": set "
- "2swap 2over --> super --> set "
- "--> set-hashcode "
- "; "
- ": cat "
- "2swap 2over --> super --> cat "
- "--> set-hashcode "
- "; "
- "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 "
- "else "
- "drop "
- "endif "
- "; "
- ": include parse-word included ; "
-#endif
-#endif /* WANT_SOFTWORDS */
- "quit ";
+static size_t ficlSoftcoreUncompressedSize = 25687; /* not including trailing null */
+
+#if !FICL_WANT_LZ_SOFTCORE
+
+static char ficlSoftcoreUncompressed[] =
+ ": empty ( xn..x1 -- ) depth 0 ?do drop loop ;\n"
+ ": cell- ( addr -- addr ) [ 1 cells ] literal - ;\n"
+ ": -rot ( a b c -- c a b ) 2 -roll ;\n"
+ ": abs ( x -- x )\n"
+ "dup 0< if negate endif ;\n"
+ "decimal 32 constant bl\n"
+ ": space ( -- ) bl emit ;\n"
+ ": spaces ( n -- ) 0 ?do space loop ;\n"
+ ": abort\"\n"
+ "state @ if\n"
+ "postpone if\n"
+ "postpone .\"\n"
+ "postpone cr\n"
+ "-2\n"
+ "postpone literal\n"
+ "postpone throw\n"
+ "postpone endif\n"
+ "else\n"
+ "[char] \" parse\n"
+ "rot if\n"
+ "type\n"
+ "cr\n"
+ "-2 throw\n"
+ "else\n"
+ "2drop\n"
+ "endif\n"
+ "endif\n"
+ "; immediate\n"
+ ".( loading CORE EXT words ) cr\n"
+ "0 constant false\n"
+ "false invert constant true\n"
+ ": <> = 0= ;\n"
+ ": 0<> 0= 0= ;\n"
+ ": compile, , ;\n"
+ ": convert char+ 65535 >number drop ; \\ cribbed from DPANS A.6.2.0970\n"
+ ": erase ( addr u -- ) 0 fill ;\n"
+ "variable span\n"
+ ": expect ( c-addr u1 -- ) accept span ! ;\n"
+ ": nip ( y x -- x ) swap drop ;\n"
+ ": tuck ( y x -- x y x) swap over ;\n"
+ ": within ( test low high -- flag ) over - >r - r> u< ;\n"
+ ": ? ( addr -- ) @ . ;\n"
+ ": dump ( addr u -- )\n"
+ "0 ?do\n"
+ "dup c@ . 1+\n"
+ "i 7 and 7 = if cr endif\n"
+ "loop drop\n"
+ ";\n"
+ ".( loading SEARCH & SEARCH-EXT words ) cr\n"
+ ": brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;\n"
+ ": ficl-named-wordlist \\ ( hash-size name -- ) run: ( -- wid )\n"
+ "ficl-wordlist dup create , brand-wordlist does> @ ;\n"
+ ": wordlist ( -- )\n"
+ "1 ficl-wordlist ;\n"
+ ": ficl-set-current ( wid -- old-wid )\n"
+ "get-current swap set-current ;\n"
+ ": do-vocabulary ( -- )\n"
+ "does> @ search> drop >search ;\n"
+ ": ficl-vocabulary ( nBuckets name -- )\n"
+ "ficl-named-wordlist do-vocabulary ;\n"
+ ": vocabulary ( name -- )\n"
+ "1 ficl-vocabulary ;\n"
+ ": previous ( -- ) search> drop ;\n"
+ "1 ficl-named-wordlist hidden\n"
+ ": hide hidden dup >search ficl-set-current ;\n"
+ ": also ( -- )\n"
+ "search> dup >search >search ;\n"
+ ": forth ( -- )\n"
+ "search> drop\n"
+ "forth-wordlist >search ;\n"
+ ": only ( -- )\n"
+ "-1 set-order ;\n"
+ "hide\n"
+ ": list-wid ( wid -- )\n"
+ "dup wid-get-name ( wid c-addr u )\n"
+ "?dup if\n"
+ "type drop\n"
+ "else\n"
+ "drop .\" (unnamed wid) \" x.\n"
+ "endif cr\n"
+ ";\n"
+ "set-current \\ stop hiding words\n"
+ ": order ( -- )\n"
+ ".\" Search:\" cr\n"
+ "get-order 0 ?do 3 spaces list-wid loop cr\n"
+ ".\" Compile: \" get-current list-wid cr\n"
+ ";\n"
+ ": debug ' debug-xt ; immediate\n"
+ ": on-step .\" S: \" .s-simple cr ;\n"
+ "previous \\ lose hidden words from search order\n"
+ "hide\n"
+ ": ?[if] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [if]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[else] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [else]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[then] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [then]\" compare-insensitive 0= >r\n"
+ "2dup s\" [endif]\" compare-insensitive 0= r>\n"
+ "or\n"
+ ";\n"
+ "set-current\n"
+ ": [else] ( -- )\n"
+ "1 \\ ( level )\n"
+ "begin\n"
+ "begin\n"
+ "parse-word dup while \\ ( level addr len )\n"
+ "?[if] if \\ ( level addr len )\n"
+ "2drop 1+ \\ ( level )\n"
+ "else \\ ( level addr len )\n"
+ "?[else] if \\ ( level addr len )\n"
+ "2drop 1- dup if 1+ endif\n"
+ "else\n"
+ "?[then] if 2drop 1- else 2drop endif\n"
+ "endif\n"
+ "endif ?dup 0= if exit endif \\ level\n"
+ "repeat 2drop \\ level\n"
+ "refill 0= until \\ level\n"
+ "drop\n"
+ "; immediate\n"
+ ": [if] ( flag -- )\n"
+ "0= if postpone [else] then ; immediate\n"
+ ": [then] ( -- ) ; immediate\n"
+ ": [endif] ( -- ) ; immediate\n"
+ "previous\n"
+ "variable save-current\n"
+ ": start-prefixes get-current save-current ! <prefixes> set-current ;\n"
+ ": end-prefixes save-current @ set-current ;\n"
+ ": show-prefixes <prefixes> >search words search> drop ;\n"
+ "start-prefixes\n"
+ "S\" FICL_WANT_EXTENDED_PREFIX\" ENVIRONMENT? drop [if]\n"
+ ": \" postpone s\" ; immediate\n"
+ ": .( postpone .( ; immediate\n"
+ ": \\ postpone \\ ; immediate\n"
+ ": // postpone \\ ; immediate\n"
+ ": 0b 2 __tempbase ; immediate\n"
+ ": 0o 8 __tempbase ; immediate\n"
+ "[endif]\n"
+ ": 0d 10 __tempbase ; immediate\n"
+ ": 0x 16 __tempbase ; immediate\n"
+ "end-prefixes\n"
+ "S\" FICL_WANT_USER\" ENVIRONMENT? drop [if]\n"
+ "variable nUser 0 nUser !\n"
+ ": user \\ name ( -- )\n"
+ "nUser dup @ user 1 swap +! ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ": locals| ( name...name | -- )\n"
+ "begin\n"
+ "bl word count\n"
+ "dup 0= abort\" where's the delimiter??\"\n"
+ "over c@\n"
+ "[char] | - over 1- or\n"
+ "while\n"
+ "(local)\n"
+ "repeat 2drop 0 0 (local)\n"
+ "; immediate\n"
+ ": local ( name -- ) bl word count (local) ; immediate\n"
+ ": 2local ( name -- ) bl word count (2local) ; immediate\n"
+ ": end-locals ( -- ) 0 0 (local) ; immediate\n"
+ ": strdup ( c-addr length -- c-addr2 length2 ior )\n"
+ "0 locals| addr2 length c-addr | end-locals\n"
+ "length 1 + allocate\n"
+ "0= if\n"
+ "to addr2\n"
+ "c-addr addr2 length move\n"
+ "addr2 length 0\n"
+ "else\n"
+ "0 -1\n"
+ "endif\n"
+ ";\n"
+ ": strcat ( 2:a 2:b -- 2:new-a )\n"
+ "0 locals| b-length b-u b-addr a-u a-addr | end-locals\n"
+ "b-u to b-length\n"
+ "b-addr a-addr a-u + b-length move\n"
+ "a-addr a-u b-length +\n"
+ ";\n"
+ ": strcpy ( 2:a 2:b -- 2:new-a )\n"
+ "locals| b-u b-addr a-u a-addr | end-locals\n"
+ "a-addr 0 b-addr b-u strcat\n"
+ ";\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ".( loading Johns-Hopkins locals ) cr\n"
+ "hide\n"
+ ": compiled-zero ficlInstruction0 , ;\n"
+ ": compiled-float-zero ficlInstructionF0 , ;\n"
+ ": ?-- ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" --\" compare 0= ;\n"
+ ": ?} ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" }\" compare 0= ;\n"
+ ": ?| ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" |\" compare 0= ;\n"
+ "1 constant local-is-double\n"
+ "2 constant local-is-float\n"
+ ": parse-local-prefix-flags ( c-addr u -- c-addr u flags )\n"
+ "0 0 0 locals| stop-loop colon-offset flags u c-addr |\n"
+ "c-addr c@ [char] : =\n"
+ "if\n"
+ "over over 0 exit\n"
+ "endif\n"
+ "u 0 do\n"
+ "c-addr i + c@\n"
+ "case\n"
+ "[char] 1 of flags local-is-double invert and to flags endof\n"
+ "[char] 2 of flags local-is-double or to flags endof\n"
+ "[char] d of flags local-is-double or to flags endof\n"
+ "[char] f of flags local-is-float or to flags endof\n"
+ "[char] i of flags local-is-float invert and to flags endof\n"
+ "[char] s of flags local-is-double invert and to flags endof\n"
+ "[char] : of i 1+ to colon-offset 1 to stop-loop endof\n"
+ "1 to stop-loop\n"
+ "endcase\n"
+ "stop-loop if leave endif\n"
+ "loop\n"
+ "colon-offset 0=\n"
+ "colon-offset u =\n"
+ "or\n"
+ "if\n"
+ "c-addr u 0 exit\n"
+ "endif\n"
+ "c-addr colon-offset +\n"
+ "u colon-offset -\n"
+ "flags\n"
+ ";\n"
+ ": ?delim ( c-addr u -- state | c-addr u 0 )\n"
+ "?| if 2drop 1 exit endif\n"
+ "?-- if 2drop 2 exit endif\n"
+ "?} if 2drop 3 exit endif\n"
+ "dup 0=\n"
+ "if 2drop 4 exit endif\n"
+ "0\n"
+ ";\n"
+ "set-current\n"
+ ": {\n"
+ "0 0 0 locals| flags local-state nLocals |\n"
+ "begin\n"
+ "parse-word ?delim dup to local-state\n"
+ "0= while\n"
+ "nLocals 1+ to nLocals\n"
+ "repeat\n"
+ "nLocals 0 ?do\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if (f2local) else (2local) endif\n"
+ "else\n"
+ "flags local-is-float and if (flocal) else (local) endif\n"
+ "endif\n"
+ "loop \\ ( )\n"
+ "local-state 1 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "0= while\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero compiled-float-zero (f2local)\n"
+ "else\n"
+ "compiled-zero compiled-zero (2local)\n"
+ "endif\n"
+ "else\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero (flocal)\n"
+ "else\n"
+ "compiled-zero (local)\n"
+ "endif\n"
+ "endif\n"
+ "repeat\n"
+ "endif\n"
+ "0 0 (local)\n"
+ "local-state 2 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "3 < while\n"
+ "local-state 0= if 2drop endif\n"
+ "repeat\n"
+ "endif\n"
+ "local-state 3 <> abort\" syntax error in { } local line\"\n"
+ "; immediate compile-only\n"
+ "previous\n"
+ "[endif]\n"
+ ".( loading MARKER ) cr\n"
+ ": marker ( \"name\" -- )\n"
+ "create\n"
+ "get-current ,\n"
+ "get-order dup ,\n"
+ "0 ?do , loop\n"
+ "does>\n"
+ "0 set-order \\ clear search order\n"
+ "dup body> >name drop\n"
+ "here - allot \\ reset HERE to my xt-addr\n"
+ "dup @ ( pfa current-wid )\n"
+ "dup set-current forget-wid ( pfa )\n"
+ "cell+ dup @ swap ( count count-addr )\n"
+ "over cells + swap ( last-wid-addr count )\n"
+ "0 ?do\n"
+ "dup @ dup ( wid-addr wid wid )\n"
+ ">search forget-wid ( wid-addr )\n"
+ "cell-\n"
+ "loop\n"
+ "drop\n"
+ ";\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl O-O extensions ) cr\n"
+ "17 ficl-vocabulary oop\n"
+ "also oop definitions\n"
+ "user current-class\n"
+ "0 current-class !\n"
+ ": parse-method \\ name run: ( -- c-addr u )\n"
+ "parse-word\n"
+ "postpone sliteral\n"
+ "; compile-only\n"
+ ": (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 }\n"
+ "class name class cell+ @ ( class c-addr u wid )\n"
+ "search-wordlist\n"
+ ";\n"
+ ": lookup-method { class 2:name -- class xt }\n"
+ "class name (lookup-method) ( 0 | xt 1 | xt -1 )\n"
+ "0= if\n"
+ "name type .\" not found in \"\n"
+ "class body> >name type\n"
+ "cr abort\n"
+ "endif\n"
+ ";\n"
+ ": find-method-xt \\ name ( class -- class xt )\n"
+ "parse-word lookup-method\n"
+ ";\n"
+ ": catch-method ( instance class c-addr u -- <method-signature> exc-flag )\n"
+ "lookup-method catch\n"
+ ";\n"
+ ": exec-method ( instance class c-addr u -- <method-signature> )\n"
+ "lookup-method execute\n"
+ ";\n"
+ ": --> ( instance class -- ??? )\n"
+ "state @ 0= if\n"
+ "find-method-xt execute\n"
+ "else\n"
+ "parse-method postpone exec-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": c-> ( instance class -- ?? exc-flag )\n"
+ "state @ 0= if\n"
+ "find-method-xt catch\n"
+ "else\n"
+ "parse-method postpone catch-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": method create does> body> >name lookup-method execute ;\n"
+ "1 ficl-named-wordlist instance-vars\n"
+ "instance-vars dup >search ficl-set-current\n"
+ ": => \\ c:( class meta -- ) run: ( -- ??? ) invokes compiled method\n"
+ "drop find-method-xt compile, drop\n"
+ "; immediate compile-only\n"
+ ": my=> \\ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class\n"
+ "current-class @ dup postpone =>\n"
+ "; immediate compile-only\n"
+ ": my=[ \\ same as my=> , but binds a chain of methods\n"
+ "current-class @\n"
+ "begin\n"
+ "parse-word 2dup ( class c-addr u c-addr u )\n"
+ "s\" ]\" compare while ( class c-addr u )\n"
+ "lookup-method ( class xt )\n"
+ "dup compile, ( class xt )\n"
+ "dup ?object if \\ If object member, get new class. Otherwise assume same class\n"
+ "nip >body cell+ @ ( new-class )\n"
+ "else\n"
+ "drop ( class )\n"
+ "endif\n"
+ "repeat 2drop drop\n"
+ "; immediate compile-only\n"
+ ": do-instance-var\n"
+ "does> ( instance class addr[offset] -- addr[field] )\n"
+ "nip @ +\n"
+ ";\n"
+ ": addr-units: ( offset size \"name\" -- offset' )\n"
+ "create over , +\n"
+ "do-instance-var\n"
+ ";\n"
+ ": chars: \\ ( offset nCells \"name\" -- offset' ) Create n char member.\n"
+ "chars addr-units: ;\n"
+ ": char: \\ ( offset nCells \"name\" -- offset' ) Create 1 char member.\n"
+ "1 chars: ;\n"
+ ": cells: ( offset nCells \"name\" -- offset' )\n"
+ "cells >r aligned r> addr-units:\n"
+ ";\n"
+ ": cell: ( offset nCells \"name\" -- offset' )\n"
+ "1 cells: ;\n"
+ ": do-aggregate\n"
+ "objectify\n"
+ "does> ( instance class pfa -- a-instance a-class )\n"
+ "2@ ( inst class a-class a-offset )\n"
+ "2swap drop ( a-class a-offset inst )\n"
+ "+ swap ( a-inst a-class )\n"
+ ";\n"
+ ": obj: { offset class meta -- offset' } \\ \"name\"\n"
+ "create offset , class ,\n"
+ "class meta --> get-size offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": array: ( offset n class meta \"name\" -- offset' )\n"
+ "locals| meta class nobjs offset |\n"
+ "create offset , class ,\n"
+ "class meta --> get-size nobjs * offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": ref: ( offset class meta \"name\" -- offset' )\n"
+ "locals| meta class offset |\n"
+ "create offset , class ,\n"
+ "offset cell+\n"
+ "does> ( inst class pfa -- ptr-inst ptr-class )\n"
+ "2@ ( inst class ptr-class ptr-offset )\n"
+ "2swap drop + @ swap\n"
+ ";\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": vcall: ( paramcnt \"name\" -- )\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall \\ ( params offset inst class offset -- )\n"
+ ";\n"
+ ": vcallr: 0x80000000 or vcall: ; \\ Call with return address desired.\n"
+ "S\" FICL_WANT_FLOAT\" ENVIRONMENT? drop [if]\n"
+ ": vcallf: \\ ( paramcnt -<name>- f: r )\n"
+ "0x80000000 or\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall f> \\ ( params offset inst class offset -- f: r )\n"
+ ";\n"
+ "[endif] \\ FICL_WANT_FLOAT\n"
+ "[endif] \\ FICL_WANT_VCALL\n"
+ ": end-class ( old-wid addr[size] size -- )\n"
+ "swap ! set-current\n"
+ "search> drop \\ pop struct builder wordlist\n"
+ ";\n"
+ ": suspend-class ( old-wid addr[size] size -- ) end-class ;\n"
+ "set-current previous\n"
+ ": do-do-instance ( -- )\n"
+ "s\" : .do-instance does> [ current-class @ ] literal ;\"\n"
+ "evaluate\n"
+ ";\n"
+ ":noname\n"
+ "wordlist\n"
+ "create\n"
+ "immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "4 cells , \\ instance size\n"
+ "[else]\n"
+ "3 cells , \\ instance size\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> dup\n"
+ "; execute metaclass\n"
+ "metaclass drop cell+ @ brand-wordlist\n"
+ "metaclass drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ "create .super ( class metaclass -- parent-class )\n"
+ "0 cells , do-instance-var\n"
+ "create .wid ( class metaclass -- wid ) \\ return wid of class\n"
+ "1 cells , do-instance-var\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ "create .vtCount \\ Number of VTABLE methods, if any\n"
+ "2 cells , do-instance-var\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "3 cells , do-instance-var\n"
+ "[else]\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "2 cells , do-instance-var\n"
+ "[endif]\n"
+ ": get-size metaclass => .size @ ;\n"
+ ": get-wid metaclass => .wid @ ;\n"
+ ": get-super metaclass => .super @ ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": get-vtCount metaclass => .vtCount @ ;\n"
+ ": get-vtAdd metaclass => .vtCount ;\n"
+ "[endif]\n"
+ ": instance ( class metaclass \"name\" -- instance class )\n"
+ "locals| meta parent |\n"
+ "create\n"
+ "here parent --> .do-instance \\ ( inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "allot \\ allocate payload space\n"
+ ";\n"
+ ": array ( n class metaclass \"name\" -- n instance class )\n"
+ "locals| meta parent nobj |\n"
+ "create nobj\n"
+ "here parent --> .do-instance \\ ( nobj inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "nobj * allot \\ allocate payload space\n"
+ ";\n"
+ ": new \\ ( class metaclass \"name\" -- )\n"
+ "metaclass => instance --> init\n"
+ ";\n"
+ ": new-array ( n class metaclass \"name\" -- )\n"
+ "metaclass => array\n"
+ "--> array-init\n"
+ ";\n"
+ ": alloc \\ ( class metaclass -- instance class )\n"
+ "locals| meta class |\n"
+ "class meta metaclass => get-size allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "class 2dup --> init\n"
+ ";\n"
+ ": alloc-array \\ ( n class metaclass -- instance class )\n"
+ "locals| meta class nobj |\n"
+ "class meta metaclass => get-size\n"
+ "nobj * allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "nobj over class --> array-init\n"
+ "class\n"
+ ";\n"
+ ": allot { 2:this -- 2:instance }\n"
+ "here ( instance-address )\n"
+ "this my=> get-size allot\n"
+ "this drop 2dup --> init\n"
+ ";\n"
+ ": allot-array { nobj 2:this -- 2:instance }\n"
+ "here ( instance-address )\n"
+ "this my=> get-size nobj * allot\n"
+ "this drop 2dup ( 2instance 2instance )\n"
+ "nobj -rot --> array-init\n"
+ ";\n"
+ ": ref ( instance-addr class metaclass \"name\" -- )\n"
+ "drop create , ,\n"
+ "does> 2@\n"
+ ";\n"
+ ": resume-class { 2:this -- old-wid addr[size] size }\n"
+ "this --> .wid @ ficl-set-current ( old-wid )\n"
+ "this --> .size dup @ ( old-wid addr[size] size )\n"
+ "instance-vars >search\n"
+ ";\n"
+ ": sub ( class metaclass \"name\" -- old-wid addr[size] size )\n"
+ "wordlist\n"
+ "locals| wid meta parent |\n"
+ "parent meta metaclass => get-wid\n"
+ "wid wid-set-super \\ set superclass\n"
+ "create immediate \\ get the subclass name\n"
+ "wid brand-wordlist \\ label the subclass wordlist\n"
+ "here current-class ! \\ prep for do-do-instance\n"
+ "parent , \\ save parent class\n"
+ "wid , \\ save wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "parent meta --> get-vtCount ,\n"
+ "[endif]\n"
+ "here parent meta --> get-size dup , ( addr[size] size )\n"
+ "metaclass => .do-instance\n"
+ "wid ficl-set-current -rot\n"
+ "do-do-instance\n"
+ "instance-vars >search \\ push struct builder wordlist\n"
+ ";\n"
+ ": offset-of ( class metaclass \"name\" -- offset )\n"
+ "drop find-method-xt nip >body @ ;\n"
+ ": id ( class metaclass -- c-addr u )\n"
+ "drop body> >name ;\n"
+ ": methods \\ ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type .\" methods:\" cr\n"
+ "class meta --> get-wid >search words cr previous\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": pedigree ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type space\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": see ( class meta -- )\n"
+ "metaclass => get-wid >search see previous ;\n"
+ ": debug ( class meta -- )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "metaclass drop\n"
+ "constant meta\n"
+ ": subclass --> sub ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": hasvtable 4 + ; immediate\n"
+ "[endif]\n"
+ ":noname\n"
+ "wordlist\n"
+ "create immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "0 , \\ instance size\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "0 , \\ .vtCount\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> meta\n"
+ "; execute object\n"
+ "object drop cell+ @ brand-wordlist\n"
+ "object drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ ": class ( instance class -- class metaclass )\n"
+ "nip meta ;\n"
+ ": init ( instance class -- )\n"
+ "meta\n"
+ "metaclass => get-size ( inst size )\n"
+ "erase ;\n"
+ ": array-init ( nobj inst class -- )\n"
+ "0 dup locals| &init &next class inst |\n"
+ "class s\" init\" lookup-method to &init\n"
+ "s\" next\" lookup-method to &next\n"
+ "drop\n"
+ "0 ?do\n"
+ "inst class 2dup\n"
+ "&init execute\n"
+ "&next execute drop to inst\n"
+ "loop\n"
+ ";\n"
+ ": free \\ ( instance class -- )\n"
+ "drop free\n"
+ "abort\" free failed \"\n"
+ ";\n"
+ ": super ( instance class -- instance parent-class )\n"
+ "meta metaclass => get-super ;\n"
+ ": pedigree ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => pedigree ;\n"
+ ": size ( instance class -- sizeof-instance )\n"
+ "object => class\n"
+ "metaclass => get-size ;\n"
+ ": methods ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => methods ;\n"
+ ": index ( n instance class -- instance[n] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size * ( n*size )\n"
+ "inst + class ;\n"
+ ": next ( instance[n] class -- instance[n+1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst +\n"
+ "class ;\n"
+ ": prev ( instance[n] class -- instance[n-1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst swap -\n"
+ "class ;\n"
+ ": debug ( 2this -- ?? )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "only definitions\n"
+ ": oo only also oop definitions ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl utility classes ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-ref\n"
+ "cell: .class\n"
+ "cell: .instance\n"
+ ": get ( inst class -- refinst refclass )\n"
+ "drop 2@ ;\n"
+ ": set ( refinst refclass inst class -- )\n"
+ "drop 2! ;\n"
+ "end-class\n"
+ "object subclass c-byte\n"
+ "char: .payload\n"
+ ": get drop c@ ;\n"
+ ": set drop c! ;\n"
+ "end-class\n"
+ "object subclass c-2byte\n"
+ "2 chars: .payload\n"
+ ": get drop w@ ;\n"
+ ": set drop w! ;\n"
+ "end-class\n"
+ "object subclass c-4byte\n"
+ "4 chars: .payload\n"
+ ": get drop q@ ;\n"
+ ": set drop q! ;\n"
+ "end-class\n"
+ "object subclass c-cell\n"
+ "cell: .payload\n"
+ ": get drop @ ;\n"
+ ": set drop ! ;\n"
+ "end-class\n"
+ "object subclass c-ptr\n"
+ "c-cell obj: .addr\n"
+ ": get-ptr ( inst class -- addr )\n"
+ "c-ptr => .addr\n"
+ "c-cell => get\n"
+ ";\n"
+ ": set-ptr ( addr inst class -- )\n"
+ "c-ptr => .addr\n"
+ "c-cell => set\n"
+ ";\n"
+ ": clr-ptr\n"
+ "0 -rot c-ptr => .addr c-cell => set\n"
+ ";\n"
+ ": ?null ( inst class -- flag )\n"
+ "c-ptr => get-ptr 0=\n"
+ ";\n"
+ ": inc-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size + -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": dec-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size - -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": index-ptr { index 2:this -- }\n"
+ "this --> get-ptr ( addr )\n"
+ "this --> @size index * + ( addr' )\n"
+ "this --> set-ptr\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-cellPtr\n"
+ ": @size 2drop 1 cells ;\n"
+ ": get ( inst class -- cell )\n"
+ "c-ptr => get-ptr @\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr !\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-4bytePtr\n"
+ ": @size 2drop 4 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr q@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr q!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-2bytePtr\n"
+ ": @size 2drop 2 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr w@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr w!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-bytePtr\n"
+ ": @size 2drop 1 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr c@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr c!\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl string class ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-string\n"
+ "c-cell obj: .count\n"
+ "c-cell obj: .buflen\n"
+ "c-ptr obj: .buf\n"
+ "32 constant min-buf\n"
+ ": get-count ( 2:this -- count ) my=[ .count get ] ;\n"
+ ": set-count ( count 2:this -- ) my=[ .count set ] ;\n"
+ ": ?empty ( 2:this -- flag ) --> get-count 0= ;\n"
+ ": get-buflen ( 2:this -- len ) my=[ .buflen get ] ;\n"
+ ": set-buflen ( len 2:this -- ) my=[ .buflen set ] ;\n"
+ ": get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;\n"
+ ": set-buf { ptr len 2:this -- }\n"
+ "ptr this my=[ .buf set-ptr ]\n"
+ "len this my=> set-buflen\n"
+ ";\n"
+ ": clr-buf ( 2:this -- )\n"
+ "0 0 2over my=> set-buf\n"
+ "0 -rot my=> set-count\n"
+ ";\n"
+ ": free-buf { 2:this -- }\n"
+ "this my=> get-buf\n"
+ "?dup if\n"
+ "free\n"
+ "abort\" c-string free failed\"\n"
+ "this my=> clr-buf\n"
+ "endif\n"
+ ";\n"
+ ": size-buf { size 2:this -- }\n"
+ "size 0< abort\" need positive size for size-buf\"\n"
+ "size 0= if\n"
+ "this --> free-buf exit\n"
+ "endif\n"
+ "my=> min-buf size over / 1+ * chars to size\n"
+ "this --> get-buflen 0=\n"
+ "if\n"
+ "size allocate\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "size this --> set-buflen\n"
+ "exit\n"
+ "endif\n"
+ "size this --> get-buflen > if\n"
+ "this --> get-buf size resize\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "endif\n"
+ ";\n"
+ ": set { c-addr u 2:this -- }\n"
+ "u this --> size-buf\n"
+ "u this --> set-count\n"
+ "c-addr this --> get-buf u move\n"
+ ";\n"
+ ": get { 2:this -- c-addr u }\n"
+ "this --> get-buf\n"
+ "this --> get-count\n"
+ ";\n"
+ ": cat { c-addr u 2:this -- }\n"
+ "this --> get-count u + dup >r\n"
+ "this --> size-buf\n"
+ "c-addr this --> get-buf this --> get-count + u move\n"
+ "r> this --> set-count\n"
+ ";\n"
+ ": type { 2:this -- }\n"
+ "this --> ?empty if .\" (empty) \" exit endif\n"
+ "this --> .buf --> get-ptr\n"
+ "this --> .count --> get\n"
+ "type\n"
+ ";\n"
+ ": compare ( 2string 2:this -- n )\n"
+ "--> get\n"
+ "2swap\n"
+ "--> get\n"
+ "2swap compare\n"
+ ";\n"
+ ": hashcode ( 2:this -- hashcode )\n"
+ "--> get hash\n"
+ ";\n"
+ ": free ( 2:this -- ) 2dup --> free-buf object => free ;\n"
+ "end-class\n"
+ "c-string subclass c-hashstring\n"
+ "c-2byte obj: .hashcode\n"
+ ": set-hashcode { 2:this -- }\n"
+ "this --> super --> hashcode\n"
+ "this --> .hashcode --> set\n"
+ ";\n"
+ ": get-hashcode ( 2:this -- hashcode )\n"
+ "--> .hashcode --> get\n"
+ ";\n"
+ ": set ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> set\n"
+ "--> set-hashcode\n"
+ ";\n"
+ ": cat ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> cat\n"
+ "--> set-hashcode\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_PLATFORM_OS\" ENVIRONMENT? drop S\" WIN32\" compare-insensitive 0= [if]\n"
+ ": GetProcAddress ( name-addr name-u hmodule -- address )\n"
+ "3 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "2 \\ cstringArgumentBitfield\n"
+ "(get-proc-address) \\ functionAddress\n"
+ "[\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": LoadLibrary ( name-addr name-u -- hmodule )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" LoadLibraryA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": FreeLibrary ( hmodule -- success )\n"
+ "1 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" FreeLibrary\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": DebugBreak ( -- )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" DebugBreak\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": OutputDebugString ( addr u -- )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" OutputDebugStringA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": GetTickCount ( -- ticks )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" GetTickCount\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "S\" user32.dll\" LoadLibrary constant user32.dll\n"
+ ": MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )\n"
+ "6 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "[\n"
+ "2 8 or literal \\ cstringArgumentBitfield\n"
+ "S\" MessageBoxA\" user32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "0x00000000 constant MB_OK\n"
+ "0x00000001 constant MB_OKCANCEL\n"
+ "0x00000002 constant MB_ABORTRETRYIGNORE\n"
+ "0x00000003 constant MB_YESNOCANCEL\n"
+ "0x00000004 constant MB_YESNO\n"
+ "0x00000005 constant MB_RETRYCANCEL\n"
+ "0x00000010 constant MB_ICONHAND\n"
+ "0x00000020 constant MB_ICONQUESTION\n"
+ "0x00000030 constant MB_ICONEXCLAMATION\n"
+ "0x00000040 constant MB_ICONASTERISK\n"
+ "0x00000080 constant MB_USERICON\n"
+ "0x00000000 constant MB_DEFBUTTON1\n"
+ "0x00000100 constant MB_DEFBUTTON2\n"
+ "0x00000200 constant MB_DEFBUTTON3\n"
+ "0x00000300 constant MB_DEFBUTTON4\n"
+ "0x00000000 constant MB_APPLMODAL\n"
+ "0x00001000 constant MB_SYSTEMMODAL\n"
+ "0x00002000 constant MB_TASKMODAL\n"
+ "0x00004000 constant MB_HELP\n"
+ "0x00008000 constant MB_NOFOCUS\n"
+ "0x00010000 constant MB_SETFOREGROUND\n"
+ "0x00020000 constant MB_DEFAULT_DESKTOP_ONLY\n"
+ "0x00040000 constant MB_TOPMOST\n"
+ "0x00080000 constant MB_RIGHT\n"
+ "0x00100000 constant MB_RTLREADING\n"
+ "MB_ICONEXCLAMATION constant MB_ICONWARNING\n"
+ "MB_ICONHAND constant MB_ICONERROR\n"
+ "MB_ICONASTERISK constant MB_ICONINFORMATION\n"
+ "MB_ICONHAND constant MB_ICONSTOP\n"
+ "0x00200000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X\n"
+ "0x0000000F constant MB_TYPEMASK\n"
+ "0x000000F0 constant MB_ICONMASK\n"
+ "0x00000F00 constant MB_DEFMASK\n"
+ "0x00003000 constant MB_MODEMASK\n"
+ "0x0000C000 constant MB_MISCMASK\n"
+ "1 constant IDOK\n"
+ "2 constant IDCANCEL\n"
+ "3 constant IDABORT\n"
+ "4 constant IDRETRY\n"
+ "5 constant IDIGNORE\n"
+ "6 constant IDYES\n"
+ "7 constant IDNO\n"
+ "8 constant IDCLOSE\n"
+ "9 constant IDHELP\n"
+ ": output-debug-string OutputDebugString ;\n"
+ ": debug-break DebugBreak ;\n"
+ ": uaddr->cstring { addr u | cstring -- cstring }\n"
+ "u 1+ allocate\n"
+ "0= if\n"
+ "to cstring\n"
+ "addr cstring u move\n"
+ "0 cstring u + c!\n"
+ "cstring\n"
+ "else\n"
+ "0\n"
+ "endif\n"
+ ";\n"
+ ": callnativeFunction { functionAddress popStack -- }\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "functionAddress \\ functionAddress\n"
+ "[\n"
+ "multicall-calltype-function\n"
+ "multicall-returntype-integer or\n"
+ "multicall-reverse-arguments or\n"
+ "literal\n"
+ "]\n"
+ "multicall\n"
+ ";\n"
+ ": callcfunction 1 callnativeFunction ;\n"
+ ": callpascalfunction 0 callnativeFunction ;\n"
+ ": vcall { argumentCount index -- }\n"
+ "argumentCount 0x80000000 invert or \\ cleaned-up argumentCount\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "0 \\ cstringFlags\n"
+ "index \\ index\n"
+ "argumentCount 0x80000000 and if multicall-returntype-integer else multicall-returntype-void endif\n"
+ "[\n"
+ "multicall-calltype-virtual-method\n"
+ "multicall-reverse-arguments or\n"
+ "literal\n"
+ "] or\n"
+ "multicall\n"
+ ";\n"
+ "[endif]\n"
+ "hide\n"
+ "0 constant zero\n"
+ ": ?-- s\" --\" compare 0= ;\n"
+ ": ?}} s\" }}\" compare 0= ;\n"
+ "set-current\n"
+ ": {{\n"
+ "0 dup locals| nLocs locstate |\n"
+ "begin\n"
+ "parse-word\n"
+ "?dup 0= abort\" Error: out of text without seeing }}\"\n"
+ "2dup 2dup ?-- -rot ?}} or 0=\n"
+ "while\n"
+ "nLocs 1+ to nLocs\n"
+ "repeat\n"
+ "?-- if 1 to locstate endif\n"
+ "nLocs 0 do\n"
+ "(local)\n"
+ "loop\n"
+ "locstate 1 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "2dup ?}} 0=\n"
+ "while\n"
+ "postpone zero (local)\n"
+ "repeat\n"
+ "2drop\n"
+ "endif\n"
+ "0 0 (local)\n"
+ "; immediate compile-only\n"
+ "previous\n"
+ "S\" FICL_WANT_FILE\" ENVIRONMENT? drop [if]\n"
+ ": r/o 1 ;\n"
+ ": r/w 3 ;\n"
+ ": w/o 2 ;\n"
+ ": bin 8 or ;\n"
+ ": included\n"
+ "r/o bin open-file 0= if\n"
+ "include-file\n"
+ "else\n"
+ "drop\n"
+ "endif\n"
+ ";\n"
+ ": include parse-word included ;\n"
+ "[endif]\n"
+;
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
+#else /* !FICL_WANT_LZ_SOFTCORE */
+
+static unsigned char ficlSoftcoreCompressed[11490] = {
+ 0xfe, 0x00, 0x01, 0x66, 0xcd, 0xfd, 0x64, 0x57,
+ 0x1d, 0x08, 0x0c, 0xa6, 0xd3, 0x81, 0xd0, 0xf2,
+ 0x20, 0x14, 0x08, 0x0f, 0x06, 0xe1, 0x70, 0xb8,
+ 0xf0, 0x31, 0x10, 0x0b, 0x45, 0xa2, 0x01, 0x48,
+ 0x80, 0xc8, 0x65, 0x80, 0x20, 0x1a, 0x04, 0x03,
+ 0x01, 0x00, 0xfc, 0xc8, 0x6f, 0x80, 0xa8, 0x1c,
+ 0x8d, 0xe7, 0x01, 0x01, 0xb0, 0xdf, 0x02, 0x40,
+ 0x9d, 0x82, 0xa0, 0x00, 0x06, 0x33, 0x29, 0xb0,
+ 0xd9, 0x01, 0x20, 0x14, 0x08, 0x0c, 0x26, 0x48,
+ 0x11, 0x00, 0x82, 0x02, 0x21, 0x61, 0x81, 0xc8,
+ 0x8a, 0x44, 0x05, 0xb1, 0x04, 0x03, 0xc0, 0xc7,
+ 0x03, 0x10, 0xb9, 0x88, 0x0b, 0xb0, 0x26, 0x03,
+ 0x49, 0xd0, 0xca, 0x72, 0x30, 0x9b, 0x20, 0x20,
+ 0x02, 0x08, 0x16, 0x08, 0xb6, 0x04, 0x60, 0x74,
+ 0x81, 0xa8, 0x88, 0x0c, 0x50, 0x2f, 0x01, 0x04,
+ 0x04, 0x42, 0xc7, 0x06, 0x71, 0x94, 0x88, 0x06,
+ 0x50, 0x60, 0x13, 0x64, 0x16, 0x40, 0x77, 0x02,
+ 0xd0, 0xb0, 0x98, 0xa0, 0x9e, 0x02, 0x88, 0x04,
+ 0x80, 0x82, 0x02, 0x21, 0x78, 0x80, 0x98, 0x02,
+ 0x8c, 0x87, 0x58, 0x12, 0x80, 0xc0, 0x78, 0x20,
+ 0x34, 0x99, 0x84, 0x06, 0xe3, 0x29, 0x9c, 0xc3,
+ 0x05, 0x50, 0x10, 0x19, 0x4d, 0xc6, 0x48, 0x4d,
+ 0x84, 0xee, 0x12, 0x60, 0x65, 0x31, 0x9a, 0x4d,
+ 0xb0, 0x58, 0x09, 0x9c, 0x1e, 0x40, 0xc6, 0x6f,
+ 0x37, 0x1c, 0xce, 0x86, 0x13, 0x74, 0x19, 0x00,
+ 0xc4, 0x6c, 0x81, 0x68, 0x5c, 0xce, 0x06, 0x18,
+ 0x18, 0x00, 0x82, 0x01, 0x00, 0x2d, 0x80, 0x90,
+ 0x98, 0xa0, 0xb2, 0x06, 0x53, 0x6c, 0x15, 0x00,
+ 0x41, 0x02, 0xc1, 0x39, 0xc3, 0x1c, 0x4e, 0x70,
+ 0x07, 0x0b, 0x74, 0x04, 0x08, 0x61, 0x01, 0xd1,
+ 0xb9, 0xc3, 0x1c, 0x6d, 0x90, 0x28, 0x33, 0x09,
+ 0x88, 0xde, 0x72, 0x3a, 0x08, 0x81, 0x50, 0xbb,
+ 0x0b, 0xa4, 0x28, 0xc0, 0x81, 0x09, 0xa0, 0x85,
+ 0x1c, 0x0d, 0xf0, 0xbb, 0x03, 0x84, 0x2e, 0x40,
+ 0xcb, 0x11, 0x25, 0x10, 0x0b, 0xa2, 0x12, 0x07,
+ 0x08, 0x8b, 0x99, 0x8c, 0xe4, 0x0a, 0x16, 0x8c,
+ 0xa2, 0x2a, 0x86, 0xc8, 0x2a, 0x10, 0x2a, 0x22,
+ 0xc7, 0x74, 0x34, 0x40, 0x8c, 0x0e, 0xf1, 0x15,
+ 0x43, 0x2c, 0x29, 0x84, 0x15, 0x03, 0x10, 0x39,
+ 0x99, 0x41, 0x45, 0xb3, 0x19, 0xa0, 0xc2, 0x72,
+ 0x82, 0x88, 0x08, 0x84, 0x10, 0xc7, 0x03, 0x94,
+ 0x5b, 0x82, 0xe5, 0x06, 0x30, 0xb4, 0xc4, 0x50,
+ 0x0e, 0x87, 0x93, 0x84, 0x5b, 0xc0, 0xc7, 0x13,
+ 0x81, 0x10, 0x45, 0x5c, 0x8c, 0xb1, 0x6d, 0x11,
+ 0x94, 0x08, 0x84, 0x15, 0x16, 0x62, 0xb7, 0x45,
+ 0xa0, 0x47, 0x70, 0x9a, 0x03, 0x69, 0xb4, 0xcb,
+ 0x0a, 0x70, 0x30, 0xc1, 0x54, 0x01, 0x42, 0xe8,
+ 0x04, 0x01, 0xb0, 0xdf, 0x03, 0x80, 0x34, 0x9b,
+ 0x8c, 0xe2, 0x02, 0x19, 0x3c, 0xa4, 0x45, 0x10,
+ 0x11, 0x4b, 0x05, 0x41, 0x01, 0xde, 0x20, 0xc0,
+ 0x64, 0x82, 0x78, 0x0a, 0x62, 0x6c, 0x23, 0x08,
+ 0x5b, 0xa1, 0x9a, 0x0b, 0x00, 0x73, 0x8b, 0x78,
+ 0x19, 0xa3, 0xcc, 0x22, 0x08, 0xe1, 0x01, 0xda,
+ 0x0a, 0xc0, 0x74, 0x85, 0xba, 0x1d, 0x0e, 0x47,
+ 0x58, 0xb7, 0x80, 0xe8, 0x40, 0x3c, 0x1f, 0x08,
+ 0x07, 0xb0, 0x1b, 0x01, 0xec, 0x0a, 0xc6, 0x61,
+ 0x20, 0x80, 0x98, 0x48, 0x2c, 0xec, 0x66, 0xf8,
+ 0x01, 0x81, 0xa4, 0xd8, 0x65, 0x16, 0x08, 0x24,
+ 0x52, 0x03, 0xb9, 0x0f, 0x8d, 0xba, 0x3e, 0x64,
+ 0x68, 0x8b, 0xa0, 0x0a, 0xc4, 0x03, 0x61, 0xa8,
+ 0xd4, 0x66, 0x35, 0x10, 0x0f, 0x8d, 0xc7, 0x53,
+ 0x69, 0x8a, 0x0a, 0xc0, 0x20, 0x81, 0x10, 0xce,
+ 0xc4, 0x05, 0xc8, 0x9b, 0x05, 0xa4, 0xc5, 0x24,
+ 0x90, 0x32, 0x47, 0x90, 0x0e, 0x52, 0x23, 0x01,
+ 0x01, 0x10, 0xa0, 0x41, 0x27, 0x14, 0xc4, 0x04,
+ 0x11, 0x70, 0xd8, 0x5c, 0x32, 0x17, 0x0c, 0x07,
+ 0x23, 0x71, 0x84, 0x0b, 0x42, 0xcb, 0x05, 0x70,
+ 0x39, 0xc3, 0x28, 0x4c, 0x30, 0x39, 0x13, 0xac,
+ 0x3a, 0x4c, 0xcd, 0x22, 0x60, 0x36, 0x40, 0xac,
+ 0x2e, 0xd1, 0x74, 0x03, 0x4c, 0x21, 0x40, 0xd9,
+ 0x0a, 0x30, 0x39, 0xc3, 0x1c, 0x0d, 0xd2, 0x73,
+ 0x13, 0xc4, 0x62, 0x40, 0xc7, 0x06, 0x41, 0x31,
+ 0x8b, 0x64, 0xfc, 0x43, 0x18, 0x08, 0x11, 0x84,
+ 0xc7, 0x03, 0x00, 0x38, 0x41, 0x90, 0x0e, 0x72,
+ 0x9d, 0x09, 0x00, 0x86, 0x05, 0x63, 0x6e, 0x34,
+ 0xc0, 0x94, 0x05, 0x02, 0x08, 0x03, 0x01, 0xe2,
+ 0x11, 0x85, 0x20, 0x39, 0x9d, 0xcc, 0x30, 0x25,
+ 0x03, 0x24, 0x93, 0x86, 0x15, 0x00, 0x00, 0x3a,
+ 0x1d, 0x4c, 0x66, 0xb9, 0x68, 0x29, 0xe6, 0x01,
+ 0x20, 0x29, 0x96, 0xe9, 0x1b, 0xe3, 0xe6, 0x12,
+ 0x08, 0x16, 0x09, 0xde, 0x0a, 0x80, 0x68, 0x8e,
+ 0x10, 0x08, 0x20, 0x10, 0x07, 0x48, 0x71, 0x81,
+ 0xd2, 0x04, 0xc1, 0x77, 0x10, 0x4c, 0x48, 0x0c,
+ 0xf0, 0x1a, 0x01, 0x6c, 0x04, 0x80, 0xcc, 0x6c,
+ 0x30, 0xc7, 0x10, 0x05, 0x33, 0x05, 0x21, 0x6c,
+ 0x91, 0x00, 0xe5, 0x05, 0xa0, 0xb9, 0x48, 0x24,
+ 0x0e, 0xb0, 0x99, 0x01, 0xdc, 0x0b, 0x42, 0x7f,
+ 0x03, 0x54, 0x94, 0xc4, 0x40, 0x25, 0xd0, 0x2b,
+ 0x1b, 0x24, 0x91, 0xc0, 0xe1, 0x27, 0xb6, 0x05,
+ 0x40, 0x70, 0x61, 0x50, 0x94, 0x13, 0x1c, 0xd5,
+ 0x04, 0x62, 0x2b, 0x05, 0x1a, 0x44, 0x03, 0x78,
+ 0x1b, 0x81, 0xba, 0x4b, 0x80, 0x37, 0x90, 0x50,
+ 0x5a, 0x61, 0x38, 0x06, 0x38, 0x1d, 0x81, 0x96,
+ 0x2c, 0xe3, 0x6c, 0x81, 0x40, 0x99, 0x23, 0x3e,
+ 0x23, 0xb8, 0xdd, 0x29, 0x4c, 0x8a, 0x41, 0x29,
+ 0x10, 0xc9, 0x02, 0x01, 0x34, 0xeb, 0xca, 0x5b,
+ 0x1c, 0xb6, 0x9d, 0x41, 0xa4, 0x0e, 0x53, 0x85,
+ 0x09, 0x6c, 0x73, 0xc4, 0xd8, 0x69, 0x98, 0xd0,
+ 0x4a, 0x26, 0x1c, 0x16, 0x48, 0x08, 0x11, 0xb2,
+ 0x4f, 0x00, 0x74, 0x9e, 0xb0, 0xc8, 0x24, 0x8a,
+ 0x06, 0x18, 0xd9, 0x80, 0x82, 0x04, 0x43, 0x77,
+ 0x9f, 0x18, 0x0b, 0x62, 0xdc, 0x07, 0x41, 0x6c,
+ 0xfd, 0x86, 0x77, 0x02, 0xd0, 0xb3, 0x1a, 0x4c,
+ 0x70, 0x33, 0x03, 0x74, 0xfd, 0xc2, 0xc9, 0x3d,
+ 0x64, 0x2e, 0x40, 0x1c, 0x2d, 0x12, 0x78, 0x03,
+ 0x45, 0x00, 0xc0, 0xd2, 0x7a, 0x85, 0x18, 0x1b,
+ 0xa7, 0xee, 0x22, 0xd8, 0x09, 0x09, 0xc8, 0xea,
+ 0x6e, 0x80, 0x00, 0x0a, 0x20, 0x20, 0x27, 0x79,
+ 0xf1, 0x84, 0xa6, 0x3d, 0x40, 0x69, 0xa0, 0x98,
+ 0x5d, 0xe7, 0xb0, 0x66, 0x49, 0xbb, 0x09, 0xc8,
+ 0xcb, 0x0a, 0x11, 0x16, 0x4f, 0x41, 0xcc, 0x86,
+ 0xf8, 0x71, 0x80, 0xfa, 0x22, 0x01, 0x3b, 0x98,
+ 0x60, 0x9b, 0xe7, 0xb2, 0x72, 0xd9, 0xb5, 0x88,
+ 0xc6, 0x82, 0x04, 0x77, 0x9e, 0xc1, 0x8e, 0xe8,
+ 0x1c, 0x67, 0x3a, 0x02, 0x85, 0x8c, 0xea, 0x72,
+ 0xa3, 0x00, 0x1b, 0xa7, 0xbc, 0x96, 0xf3, 0x64,
+ 0xf5, 0x42, 0xd3, 0x44, 0x91, 0x33, 0xd2, 0xb5,
+ 0x2e, 0x72, 0xdf, 0x13, 0x9d, 0x2b, 0x52, 0x77,
+ 0x35, 0x91, 0x37, 0x8b, 0x4e, 0xc6, 0xf3, 0x1c,
+ 0x21, 0x40, 0xeb, 0x32, 0xa0, 0x39, 0x40, 0x18,
+ 0x45, 0xb3, 0x6b, 0x13, 0x25, 0x1e, 0x0a, 0xe7,
+ 0x46, 0x10, 0x39, 0x45, 0xc8, 0x07, 0xd0, 0x21,
+ 0x21, 0xf5, 0x42, 0x48, 0x41, 0x40, 0xd3, 0xbb,
+ 0x53, 0xc1, 0x4d, 0xc4, 0x29, 0x76, 0x85, 0x94,
+ 0xe9, 0x04, 0xf0, 0x37, 0x50, 0xd0, 0xc1, 0x54,
+ 0x11, 0x93, 0x25, 0x3b, 0x56, 0x77, 0x02, 0xd0,
+ 0xbb, 0x54, 0xa1, 0x6c, 0x35, 0x3f, 0x31, 0x8d,
+ 0x48, 0x5e, 0x77, 0x02, 0xd0, 0xb8, 0x51, 0x80,
+ 0x0e, 0xc6, 0x93, 0x79, 0xd6, 0x10, 0xe2, 0x2d,
+ 0x80, 0x90, 0x9c, 0xea, 0x14, 0xa3, 0xba, 0x49,
+ 0x19, 0xba, 0x82, 0xec, 0x68, 0x9f, 0x18, 0x19,
+ 0x21, 0x4a, 0x00, 0xa8, 0x00, 0x01, 0xa2, 0x7c,
+ 0x60, 0x65, 0xae, 0x71, 0x48, 0x21, 0x28, 0x23,
+ 0xea, 0x8b, 0x95, 0x9a, 0x95, 0x0e, 0x3b, 0x84,
+ 0x10, 0x9b, 0x0e, 0x70, 0x20, 0x01, 0x44, 0xda,
+ 0x48, 0xe7, 0x50, 0xa3, 0x3a, 0xd4, 0x51, 0x07,
+ 0xd5, 0x17, 0x53, 0x7c, 0x41, 0xc0, 0xd1, 0x60,
+ 0x97, 0xb9, 0x46, 0x80, 0x2c, 0xd6, 0x32, 0x11,
+ 0x6c, 0xf5, 0xce, 0x7d, 0x51, 0x74, 0xb7, 0x9b,
+ 0x8d, 0x94, 0xf8, 0x39, 0x6c, 0x03, 0xc0, 0xe7,
+ 0x40, 0x50, 0xb7, 0xc7, 0x44, 0x0c, 0xb3, 0x09,
+ 0x13, 0x45, 0x76, 0x42, 0x15, 0x00, 0x00, 0x36,
+ 0x4f, 0x70, 0x25, 0xb3, 0xe2, 0x11, 0x44, 0xf8,
+ 0x4e, 0x15, 0x09, 0x41, 0x3b, 0xd0, 0x04, 0x2c,
+ 0xf4, 0x05, 0x31, 0x44, 0xf8, 0x46, 0xc7, 0x2a,
+ 0xd2, 0x90, 0x42, 0x48, 0x07, 0xf0, 0x94, 0x13,
+ 0x4c, 0x61, 0x48, 0x41, 0x19, 0xe2, 0x36, 0x45,
+ 0xb8, 0x2c, 0x90, 0x23, 0x11, 0x74, 0x5e, 0x00,
+ 0x51, 0x43, 0xe0, 0x37, 0x50, 0x5c, 0x44, 0x13,
+ 0xe2, 0x09, 0x4c, 0x5d, 0xc2, 0xf0, 0x2e, 0x8d,
+ 0x11, 0x08, 0x22, 0x6e, 0x13, 0xbb, 0x08, 0x05,
+ 0xd2, 0x95, 0xe7, 0x5c, 0x86, 0x28, 0x1d, 0x20,
+ 0x48, 0x16, 0x89, 0xf1, 0x81, 0xa6, 0x38, 0x61,
+ 0x77, 0x8e, 0x80, 0x82, 0xac, 0xc8, 0x17, 0x2b,
+ 0x3d, 0x88, 0xa2, 0x6d, 0x24, 0x2e, 0x8b, 0xc0,
+ 0x14, 0xea, 0x14, 0x33, 0xa8, 0xbc, 0x01, 0x8e,
+ 0x27, 0x00, 0x67, 0xb3, 0xb1, 0xcc, 0x20, 0x3a,
+ 0x33, 0x38, 0x6f, 0x19, 0xb2, 0xd1, 0x26, 0x6c,
+ 0x81, 0x40, 0x98, 0xe2, 0x70, 0x02, 0xe8, 0xbc,
+ 0x01, 0x0e, 0x44, 0x64, 0x3a, 0x8b, 0xb8, 0x59,
+ 0xe9, 0x5a, 0x96, 0xcb, 0x44, 0x99, 0x8e, 0xde,
+ 0xe2, 0x3a, 0x80, 0xa8, 0x58, 0x8e, 0xb1, 0xc4,
+ 0x01, 0x3d, 0xe3, 0x08, 0x5a, 0x78, 0x86, 0xc8,
+ 0x48, 0x23, 0x62, 0x83, 0xab, 0x32, 0x84, 0xb6,
+ 0x17, 0x60, 0x65, 0xb6, 0xc0, 0xd4, 0xee, 0xda,
+ 0x22, 0xe3, 0x9d, 0x0b, 0x42, 0xda, 0x70, 0x94,
+ 0xc8, 0x58, 0xe6, 0x12, 0x27, 0x0a, 0xcd, 0x99,
+ 0x72, 0x04, 0xc1, 0x73, 0xae, 0xd9, 0xdd, 0xe3,
+ 0xa0, 0x36, 0x69, 0x2f, 0x89, 0xce, 0xa3, 0x04,
+ 0x6f, 0xb3, 0xd0, 0x82, 0xad, 0x02, 0x53, 0xf2,
+ 0xdc, 0x26, 0xc0, 0xbb, 0x2a, 0x94, 0x90, 0x41,
+ 0xb8, 0x45, 0xb2, 0x7e, 0x2b, 0x34, 0xca, 0x86,
+ 0x15, 0x19, 0xd0, 0x3a, 0xd3, 0x68, 0x24, 0x50,
+ 0x46, 0x03, 0x4e, 0x01, 0x00, 0x45, 0x22, 0x11,
+ 0xb0, 0xd1, 0x80, 0x05, 0xb1, 0xc2, 0x03, 0x9c,
+ 0x29, 0x40, 0xe7, 0x05, 0x40, 0x34, 0xc7, 0xcc,
+ 0x04, 0x12, 0x0d, 0x00, 0x54, 0xd0, 0x86, 0xb7,
+ 0x16, 0xc1, 0x2e, 0xe0, 0x1b, 0xee, 0xb8, 0x28,
+ 0x23, 0x2e, 0x14, 0x44, 0x45, 0x83, 0x2e, 0x3a,
+ 0x1a, 0x21, 0x4a, 0x05, 0xdc, 0x03, 0x7d, 0xd7,
+ 0x05, 0x04, 0x74, 0xc5, 0x10, 0x88, 0xb0, 0x65,
+ 0x52, 0x09, 0x9b, 0x80, 0x2b, 0x0e, 0x88, 0x6e,
+ 0x85, 0x38, 0x57, 0x71, 0xa7, 0x77, 0x21, 0xf0,
+ 0x2a, 0x20, 0xc0, 0x0a, 0xb7, 0xca, 0xc2, 0xa0,
+ 0x00, 0x05, 0xbc, 0x28, 0x18, 0xb6, 0x91, 0xe4,
+ 0x5c, 0x80, 0x38, 0x5b, 0x2b, 0x38, 0x06, 0x58,
+ 0x2c, 0x80, 0xa4, 0x15, 0x24, 0x90, 0x33, 0xc7,
+ 0x08, 0x01, 0x59, 0x49, 0x23, 0x84, 0x5e, 0xc4,
+ 0x5b, 0x3f, 0x01, 0xb2, 0x5a, 0x74, 0x4d, 0x12,
+ 0x26, 0x09, 0x06, 0x4f, 0x50, 0xc3, 0x03, 0x91,
+ 0x36, 0x57, 0x84, 0x25, 0x36, 0xbd, 0x02, 0xde,
+ 0x00, 0xc4, 0xd3, 0x09, 0xc0, 0x2e, 0x65, 0xae,
+ 0x46, 0x50, 0x22, 0x19, 0x8c, 0x8f, 0x40, 0xb9,
+ 0x93, 0xe4, 0xb2, 0xc7, 0xb4, 0x4b, 0x99, 0x6b,
+ 0xa3, 0x2e, 0x14, 0x46, 0xd3, 0x98, 0x6e, 0x16,
+ 0xd1, 0x68, 0x6d, 0x30, 0x9c, 0x01, 0x8c, 0x8f,
+ 0x40, 0xcb, 0x16, 0x74, 0x1f, 0xe2, 0x80, 0xad,
+ 0x30, 0x9c, 0x01, 0x96, 0x7b, 0x4c, 0xcb, 0x1e,
+ 0xd1, 0x19, 0x40, 0x88, 0x6c, 0xb1, 0xa4, 0x4b,
+ 0x2c, 0x29, 0x86, 0x7f, 0x09, 0x41, 0x9e, 0xc2,
+ 0x68, 0x4c, 0xa7, 0x88, 0x6c, 0x05, 0x96, 0x14,
+ 0xc3, 0x5c, 0xca, 0x01, 0x02, 0xa8, 0xc0, 0x07,
+ 0x0a, 0x30, 0x84, 0x83, 0x33, 0xa4, 0x5c, 0xd2,
+ 0x91, 0xd9, 0xa5, 0x1a, 0x23, 0x09, 0x05, 0x81,
+ 0xd6, 0x17, 0xc0, 0x69, 0x82, 0xc8, 0x17, 0x34,
+ 0xa4, 0x56, 0x49, 0xcf, 0x8c, 0x82, 0xf4, 0x0a,
+ 0x5b, 0xc0, 0x19, 0x19, 0xa6, 0x54, 0x22, 0xd9,
+ 0xb5, 0x8c, 0xf6, 0x13, 0x42, 0x70, 0x88, 0xb9,
+ 0x96, 0xf0, 0xa0, 0x47, 0x4c, 0x51, 0x04, 0x83,
+ 0x51, 0x6d, 0x74, 0xc5, 0x11, 0x4b, 0x60, 0x24,
+ 0x23, 0xbd, 0x46, 0x31, 0x97, 0x1f, 0x23, 0x20,
+ 0xd6, 0xd4, 0x5c, 0x2b, 0x36, 0x50, 0xa9, 0x49,
+ 0xa1, 0x86, 0x3e, 0x60, 0x2d, 0xc9, 0x1a, 0x1c,
+ 0xe1, 0x78, 0x07, 0x29, 0xf7, 0x01, 0xc3, 0x4d,
+ 0xc2, 0x78, 0x87, 0x18, 0x59, 0xe9, 0x98, 0xa6,
+ 0x1d, 0x8f, 0x20, 0x82, 0x58, 0xe0, 0x3c, 0xd9,
+ 0x89, 0x8f, 0xa9, 0xb6, 0xf6, 0x59, 0xea, 0x05,
+ 0xc3, 0x66, 0x46, 0x73, 0xda, 0x3a, 0x90, 0x29,
+ 0xb6, 0xf7, 0x33, 0x44, 0x56, 0x80, 0x5b, 0xb3,
+ 0x13, 0x9e, 0x6d, 0x59, 0x07, 0xd5, 0x17, 0x2b,
+ 0xbc, 0x74, 0x06, 0xe7, 0x5a, 0xb6, 0x39, 0xec,
+ 0xb1, 0x61, 0x45, 0x38, 0xbc, 0x01, 0x18, 0x92,
+ 0x43, 0x26, 0x17, 0xca, 0xf2, 0x65, 0x02, 0xa1,
+ 0x7e, 0x39, 0x61, 0x45, 0x27, 0x11, 0x08, 0xa4,
+ 0x42, 0xf9, 0x42, 0x39, 0x00, 0x46, 0x24, 0x96,
+ 0x22, 0xf0, 0x04, 0x52, 0x71, 0x58, 0x92, 0x52,
+ 0x27, 0x93, 0x89, 0xbb, 0xf1, 0x02, 0xa4, 0xd1,
+ 0x80, 0xc9, 0x02, 0x31, 0x2d, 0xe0, 0x0c, 0x21,
+ 0x57, 0x6d, 0x13, 0x84, 0x45, 0xcc, 0xe7, 0x17,
+ 0x80, 0x1d, 0xde, 0x7d, 0x65, 0xd0, 0x08, 0x03,
+ 0x84, 0x48, 0xce, 0x51, 0x79, 0xd6, 0xae, 0x6a,
+ 0xbd, 0x0b, 0x97, 0x9d, 0x69, 0x78, 0xbf, 0x8a,
+ 0x58, 0x30, 0x83, 0x50, 0x0c, 0x84, 0x05, 0xf2,
+ 0xfc, 0x15, 0x40, 0xda, 0x70, 0x31, 0x49, 0xe0,
+ 0x47, 0x7c, 0x7b, 0x63, 0x78, 0x80, 0x71, 0xc8,
+ 0xcb, 0x2d, 0xe3, 0xe0, 0x81, 0x52, 0x12, 0x0b,
+ 0x24, 0x12, 0x00, 0x61, 0xc8, 0xcc, 0xbc, 0x41,
+ 0x20, 0x06, 0xdc, 0x8c, 0xb3, 0x2e, 0xdc, 0x52,
+ 0x15, 0xbe, 0x15, 0xaa, 0xce, 0xc0, 0x0a, 0x5b,
+ 0xfd, 0xbb, 0xb4, 0xa5, 0x0c, 0xdc, 0x55, 0x8b,
+ 0x70, 0x1c, 0xa0, 0x36, 0x16, 0xee, 0xa4, 0x8c,
+ 0x86, 0x05, 0xa1, 0x75, 0xea, 0x50, 0x97, 0x28,
+ 0x64, 0x42, 0x89, 0xb4, 0x91, 0xbb, 0xa9, 0x23,
+ 0x64, 0x84, 0xa8, 0x50, 0x3a, 0xb2, 0x43, 0x19,
+ 0x6e, 0x90, 0xae, 0x58, 0xe2, 0x5b, 0xe6, 0x19,
+ 0x54, 0xf7, 0xc4, 0xa4, 0xc2, 0x79, 0x0c, 0x82,
+ 0x4c, 0xdf, 0x08, 0x51, 0x78, 0x01, 0x66, 0xca,
+ 0x78, 0x05, 0xb0, 0xe6, 0x7c, 0xab, 0xb9, 0x4b,
+ 0xa0, 0x18, 0x06, 0xe9, 0xfb, 0x89, 0xf2, 0x6d,
+ 0x24, 0x62, 0xca, 0x51, 0x1b, 0x23, 0x9c, 0x32,
+ 0x08, 0x5c, 0x01, 0xd7, 0x25, 0x01, 0x64, 0xd1,
+ 0xe9, 0x18, 0x62, 0x0a, 0x32, 0x0c, 0xb2, 0x01,
+ 0x96, 0x8c, 0x00, 0x27, 0x82, 0x78, 0x1d, 0x31,
+ 0x44, 0x02, 0x08, 0x0b, 0x01, 0xb2, 0x16, 0x00,
+ 0x69, 0x82, 0xa8, 0x4f, 0xc7, 0xf1, 0x09, 0x03,
+ 0x7c, 0xc1, 0xc4, 0xc6, 0x40, 0x8b, 0x81, 0x9f,
+ 0x20, 0xb4, 0x16, 0xf9, 0x83, 0x88, 0xc6, 0x97,
+ 0xe1, 0x72, 0x05, 0x65, 0x90, 0x61, 0x42, 0x8e,
+ 0xe0, 0x0c, 0xa7, 0x4b, 0x0c, 0x30, 0x80, 0xd8,
+ 0x4a, 0x3c, 0x7a, 0x53, 0xbb, 0xcf, 0xad, 0xb3,
+ 0xb8, 0x22, 0x20, 0xab, 0xc2, 0x48, 0x3b, 0xc6,
+ 0xb2, 0x0f, 0x1e, 0x14, 0x82, 0xf3, 0xcc, 0x32,
+ 0xf3, 0x5f, 0xcc, 0xbd, 0x19, 0x36, 0x59, 0xea,
+ 0x05, 0xb3, 0xb8, 0x23, 0x20, 0x86, 0x61, 0x4c,
+ 0x3c, 0xa4, 0x82, 0x0b, 0xcf, 0x31, 0xce, 0x40,
+ 0x20, 0x64, 0x84, 0xa8, 0x4a, 0x25, 0x56, 0x66,
+ 0xc8, 0x52, 0x81, 0x9e, 0x03, 0x21, 0x2d, 0xc0,
+ 0x99, 0x8c, 0xbe, 0x28, 0x53, 0x28, 0x4d, 0x01,
+ 0xbe, 0x08, 0x61, 0x0a, 0x80, 0xe0, 0x1b, 0x3b,
+ 0x82, 0x56, 0x1f, 0x91, 0x24, 0x82, 0x55, 0x85,
+ 0x7c, 0xf6, 0xc2, 0x42, 0xbe, 0x2a, 0x53, 0x1e,
+ 0xc2, 0x00, 0x82, 0x0b, 0x00, 0x6c, 0xa7, 0x80,
+ 0x5d, 0x22, 0xde, 0x03, 0x09, 0xc5, 0x88, 0x2a,
+ 0xe1, 0x40, 0x20, 0xf9, 0x08, 0xc2, 0xa5, 0x58,
+ 0x56, 0x1f, 0xa0, 0x29, 0xb6, 0x60, 0xc1, 0x0a,
+ 0xf9, 0xfa, 0xcc, 0x22, 0xd6, 0x43, 0x08, 0x08,
+ 0x00, 0xc6, 0x35, 0x06, 0x0a, 0xf8, 0x18, 0xd8,
+ 0xf4, 0xba, 0x12, 0x88, 0x3c, 0x00, 0xea, 0x0d,
+ 0x00, 0x32, 0x1d, 0x41, 0xa8, 0x05, 0xb0, 0x12,
+ 0x01, 0x90, 0xea, 0x13, 0xc0, 0x77, 0x95, 0x68,
+ 0x08, 0x3e, 0x66, 0xa6, 0x2f, 0x6e, 0x01, 0x97,
+ 0xe2, 0xe3, 0x62, 0x16, 0xca, 0x0c, 0x0c, 0x5f,
+ 0x84, 0x29, 0x6c, 0xa0, 0xc0, 0xc3, 0xf4, 0xd8,
+ 0xb1, 0x7f, 0x74, 0x2e, 0x90, 0x08, 0x03, 0x17,
+ 0xf3, 0x4a, 0x15, 0xfd, 0x13, 0xb0, 0xff, 0x28,
+ 0xc5, 0x7f, 0xb0, 0x43, 0x6f, 0xd5, 0xc6, 0x5b,
+ 0xfa, 0xf3, 0xb1, 0x7e, 0x5c, 0xc5, 0x7f, 0x60,
+ 0x3b, 0x85, 0x25, 0x04, 0x65, 0xf6, 0x09, 0x36,
+ 0x7d, 0x88, 0xee, 0xbf, 0x6b, 0xf3, 0x0c, 0x81,
+ 0x08, 0x61, 0xf4, 0x33, 0x31, 0x7c, 0xe0, 0x2e,
+ 0x7f, 0x03, 0x18, 0x57, 0x31, 0x7e, 0xad, 0xb1,
+ 0xd9, 0x17, 0x43, 0x09, 0x09, 0x46, 0xf3, 0x44,
+ 0x35, 0xc0, 0x5a, 0x48, 0x84, 0xa8, 0x1a, 0xee,
+ 0x5a, 0x12, 0x0e, 0xe5, 0x94, 0xa6, 0x03, 0x82,
+ 0x68, 0xab, 0x19, 0x18, 0xe1, 0xfa, 0x46, 0x41,
+ 0x6c, 0xc0, 0x80, 0xe5, 0x4d, 0x70, 0x33, 0x4b,
+ 0x78, 0x29, 0x30, 0xa6, 0x0b, 0x94, 0x6c, 0x40,
+ 0xe9, 0x45, 0xf0, 0x37, 0x42, 0x60, 0x05, 0x90,
+ 0xd8, 0x53, 0x20, 0xb6, 0x3a, 0xc0, 0x6f, 0x83,
+ 0x08, 0x0b, 0x7f, 0xab, 0x24, 0x6f, 0xea, 0x18,
+ 0xfe, 0x21, 0xc1, 0x28, 0xb4, 0x6f, 0xc8, 0x2d,
+ 0x1a, 0x12, 0xd1, 0x6d, 0xa3, 0xce, 0x41, 0x06,
+ 0x12, 0x9f, 0x9f, 0x6c, 0xa3, 0xf7, 0x5b, 0x28,
+ 0x8d, 0xf7, 0xf8, 0xb0, 0x7c, 0xb0, 0xb7, 0xdd,
+ 0x6c, 0x2c, 0x37, 0xcf, 0xc5, 0x34, 0xc6, 0x01,
+ 0x02, 0x73, 0xc7, 0xf8, 0x1b, 0xa1, 0xd6, 0x26,
+ 0x39, 0xe8, 0x00, 0xb6, 0x34, 0x80, 0x2d, 0x89,
+ 0xb8, 0x1d, 0x60, 0xb4, 0x10, 0xad, 0x24, 0x81,
+ 0x8f, 0xfc, 0xaf, 0x66, 0xf7, 0xe8, 0x82, 0xa6,
+ 0x78, 0x16, 0x1b, 0x7b, 0x89, 0xb3, 0xf9, 0xc3,
+ 0x70, 0xc6, 0x38, 0xcb, 0x61, 0x70, 0x27, 0x3a,
+ 0xc8, 0x69, 0xce, 0x1b, 0x23, 0x30, 0xa5, 0x48,
+ 0x5b, 0x36, 0x48, 0x57, 0x3a, 0x32, 0x84, 0xb6,
+ 0x96, 0x44, 0x6f, 0x83, 0x68, 0x1b, 0xa7, 0x8a,
+ 0x06, 0x63, 0x34, 0x53, 0x42, 0x41, 0xfb, 0x62,
+ 0x3a, 0xf2, 0x24, 0xe1, 0x53, 0xe7, 0x2b, 0x1c,
+ 0x20, 0x00, 0xb7, 0xb4, 0xa2, 0x1d, 0x42, 0xb0,
+ 0x01, 0x50, 0xb5, 0x0b, 0x7c, 0x08, 0x84, 0xdf,
+ 0x01, 0xd1, 0x18, 0x5d, 0x58, 0x61, 0x50, 0x9e,
+ 0x23, 0xad, 0x11, 0x82, 0xc9, 0x07, 0x30, 0x31,
+ 0xce, 0xc4, 0x8d, 0x3c, 0x5e, 0x0b, 0x1e, 0xc4,
+ 0x00, 0xc7, 0x98, 0x30, 0x85, 0x6c, 0x2c, 0xa6,
+ 0x30, 0x12, 0x03, 0x37, 0xdb, 0x4a, 0xd9, 0xf0,
+ 0xb6, 0x10, 0x41, 0xd4, 0x0e, 0xd3, 0x42, 0x03,
+ 0xa4, 0x11, 0xc6, 0xe9, 0xde, 0xe0, 0xb6, 0x7c,
+ 0xb0, 0x4c, 0xb0, 0x3a, 0x03, 0x7c, 0x12, 0x00,
+ 0xb7, 0xac, 0xf2, 0x19, 0x7f, 0x13, 0x0d, 0xf0,
+ 0x1d, 0x03, 0xa7, 0xf3, 0x26, 0xc9, 0xfc, 0xcf,
+ 0xb6, 0x7e, 0x61, 0xec, 0xdf, 0x5c, 0x8b, 0x37,
+ 0x5f, 0xc4, 0x41, 0xf9, 0x9b, 0xb4, 0xff, 0x36,
+ 0xed, 0x3f, 0x2a, 0xf3, 0x9f, 0xbb, 0xbe, 0xc3,
+ 0xee, 0xeb, 0x9d, 0x7a, 0xc8, 0x4d, 0x35, 0x32,
+ 0x13, 0xa4, 0x64, 0xc0, 0xc7, 0xe3, 0x75, 0x18,
+ 0xee, 0x44, 0x4e, 0x7e, 0x1b, 0x3b, 0x2f, 0xae,
+ 0x06, 0x63, 0xfe, 0xb5, 0x85, 0x49, 0x20, 0x2c,
+ 0x7e, 0x65, 0x13, 0x9f, 0x7d, 0x0e, 0xd3, 0x23,
+ 0x90, 0x36, 0x41, 0x30, 0x0e, 0xd0, 0x7f, 0x03,
+ 0x2d, 0x4f, 0x06, 0xd9, 0xfd, 0xa1, 0x31, 0xf7,
+ 0x81, 0x46, 0x13, 0x6c, 0x03, 0x1f, 0x74, 0x14,
+ 0xeb, 0xdf, 0x20, 0xb7, 0xc8, 0x1c, 0x0d, 0x31,
+ 0xd1, 0x03, 0x1c, 0x6f, 0x8c, 0x61, 0xdf, 0x05,
+ 0x31, 0xf7, 0x04, 0xad, 0xfd, 0x9c, 0x49, 0x5f,
+ 0x76, 0x82, 0xc7, 0xd8, 0xb5, 0x16, 0xc0, 0x54,
+ 0x0d, 0x9d, 0x3f, 0x08, 0x54, 0xc4, 0x86, 0xc9,
+ 0x8c, 0xe1, 0x10, 0x4b, 0x11, 0x8e, 0x75, 0xda,
+ 0x03, 0xa6, 0x1f, 0xc4, 0xc7, 0xf9, 0xc4, 0x14,
+ 0xc5, 0x60, 0x0f, 0x94, 0xa9, 0x49, 0x05, 0x34,
+ 0x90, 0x15, 0xbf, 0x71, 0x34, 0xd2, 0x3c, 0xc6,
+ 0x5f, 0xe6, 0x5b, 0xed, 0x1d, 0x90, 0x67, 0xfc,
+ 0xd5, 0x32, 0x52, 0x28, 0x61, 0x54, 0x59, 0x39,
+ 0xa7, 0xec, 0x14, 0x61, 0x34, 0xc7, 0xbd, 0xf2,
+ 0xcd, 0xac, 0xdd, 0x30, 0x4b, 0x9f, 0xd5, 0x06,
+ 0xdc, 0x4c, 0xc6, 0xc9, 0x1f, 0x26, 0x85, 0x03,
+ 0xff, 0x8f, 0x11, 0x92, 0x0e, 0xe1, 0x74, 0x88,
+ 0xe8, 0x1b, 0x3f, 0x96, 0x80, 0xa9, 0x58, 0x85,
+ 0xde, 0xff, 0x63, 0x6e, 0xfe, 0x11, 0x4c, 0x7c,
+ 0x50, 0x36, 0xef, 0xda, 0x10, 0x2a, 0x80, 0x44,
+ 0x0a, 0xfd, 0x29, 0x8c, 0x21, 0xba, 0x20, 0xad,
+ 0xf9, 0x5d, 0xd3, 0x97, 0xa5, 0x0a, 0xe4, 0x9d,
+ 0x18, 0x79, 0x34, 0x16, 0x98, 0x0d, 0x81, 0x9b,
+ 0xa3, 0x52, 0x61, 0xff, 0x20, 0xc8, 0x05, 0x06,
+ 0x6b, 0xfd, 0x19, 0x96, 0x5c, 0x22, 0x28, 0xff,
+ 0x91, 0xdb, 0xa6, 0x40, 0x76, 0x6f, 0xe0, 0xed,
+ 0xb3, 0xf8, 0x4a, 0x6c, 0xfe, 0x1a, 0xdb, 0xbb,
+ 0x42, 0x62, 0x09, 0x08, 0x08, 0xa7, 0x29, 0x44,
+ 0x2d, 0xf0, 0xc1, 0x0c, 0x77, 0x3c, 0x02, 0x09,
+ 0x5f, 0x85, 0x8a, 0x41, 0x2d, 0x0a, 0xf6, 0x3f,
+ 0xd9, 0x7d, 0xe5, 0xf7, 0x3f, 0x79, 0x7d, 0x9f,
+ 0xde, 0x55, 0x0a, 0xcb, 0xac, 0x98, 0xf2, 0xc3,
+ 0x12, 0x8f, 0x65, 0x18, 0x2a, 0x3f, 0xc3, 0x63,
+ 0xc8, 0xca, 0xd8, 0xf2, 0x16, 0xb2, 0x8f, 0xeb,
+ 0x1d, 0xbb, 0xd5, 0xdf, 0x20, 0xfb, 0xed, 0x4a,
+ 0x3d, 0x34, 0x50, 0xaf, 0xc9, 0x44, 0xa3, 0xf4,
+ 0x2c, 0x6e, 0x8b, 0x48, 0x9c, 0xbb, 0x76, 0x46,
+ 0x5e, 0x93, 0x10, 0x82, 0xb5, 0x08, 0x6c, 0xea,
+ 0x12, 0x4c, 0xbc, 0xfd, 0xf2, 0x0e, 0xa2, 0xb4,
+ 0xce, 0x4c, 0x00, 0x20, 0xa9, 0xf9, 0x1b, 0x39,
+ 0xf4, 0x93, 0x08, 0x9b, 0x8c, 0xca, 0x22, 0x89,
+ 0x72, 0xfc, 0x0a, 0x9b, 0x39, 0x9e, 0x93, 0x39,
+ 0x0f, 0x80, 0xfa, 0x97, 0xe6, 0x73, 0x3c, 0xc4,
+ 0xdc, 0x0c, 0x33, 0xa7, 0x03, 0x2c, 0x76, 0xc0,
+ 0xdf, 0x9b, 0xc0, 0xb7, 0x72, 0x44, 0x04, 0x18,
+ 0x62, 0x03, 0x65, 0x45, 0xc6, 0xd9, 0x48, 0x50,
+ 0x32, 0xd2, 0xe0, 0x07, 0x71, 0x2b, 0x41, 0x05,
+ 0xee, 0x4a, 0x5b, 0x14, 0x10, 0x36, 0x1e, 0x63,
+ 0x22, 0x85, 0xb9, 0xa0, 0x14, 0xba, 0xed, 0xe8,
+ 0x4d, 0x20, 0x94, 0x89, 0x73, 0x8b, 0x01, 0x05,
+ 0xdf, 0x46, 0x75, 0x5f, 0x40, 0x30, 0x9c, 0x8d,
+ 0x73, 0xa4, 0x09, 0x44, 0x9b, 0x00, 0xdd, 0x3b,
+ 0x40, 0x91, 0x43, 0xc8, 0x8c, 0x70, 0xa0, 0x03,
+ 0x0c, 0x36, 0x02, 0xcf, 0x17, 0xb4, 0x96, 0x7f,
+ 0xc8, 0x6d, 0xf1, 0xed, 0x03, 0x2c, 0xe7, 0x08,
+ 0x59, 0x55, 0x80, 0x9f, 0xe1, 0x6c, 0x04, 0x17,
+ 0x61, 0x03, 0x66, 0xaf, 0x84, 0xc8, 0x6f, 0x8b,
+ 0x80, 0x42, 0xa5, 0xc0, 0x07, 0x3f, 0xed, 0x9d,
+ 0x72, 0x7d, 0xa0, 0x6c, 0x8d, 0xb8, 0x48, 0x23,
+ 0x64, 0x56, 0xff, 0xe3, 0x08, 0x2a, 0x05, 0x62,
+ 0x62, 0x37, 0x99, 0x0f, 0x31, 0x9a, 0x0b, 0x74,
+ 0xd1, 0x44, 0xc9, 0x06, 0x51, 0x34, 0x4f, 0x68,
+ 0x24, 0x10, 0x7b, 0x03, 0x0d, 0x4f, 0x82, 0xe9,
+ 0x01, 0xe0, 0xb9, 0x44, 0x04, 0x0c, 0xb0, 0x10,
+ 0x02, 0x44, 0xba, 0x00, 0x8b, 0x5d, 0x71, 0x36,
+ 0xd8, 0x80, 0x0f, 0x10, 0xe8, 0x03, 0x0d, 0x31,
+ 0xc2, 0x15, 0x32, 0x52, 0x14, 0x41, 0x68, 0x0c,
+ 0xd5, 0x72, 0x03, 0x1c, 0x31, 0xc8, 0x5a, 0x77,
+ 0xb5, 0xe0, 0x08, 0x20, 0x84, 0x06, 0x4b, 0x98,
+ 0x89, 0x96, 0x19, 0xc8, 0x66, 0x8a, 0x28, 0x19,
+ 0xe1, 0x7e, 0x17, 0x7f, 0xf1, 0x84, 0xa3, 0xfa,
+ 0x23, 0x29, 0xa7, 0xc0, 0x19, 0x69, 0xbe, 0x02,
+ 0xb9, 0x71, 0x15, 0xce, 0x5d, 0x22, 0x28, 0x9f,
+ 0x39, 0x58, 0xe6, 0x8e, 0x22, 0xda, 0x33, 0x0c,
+ 0xa6, 0x6c, 0xe5, 0x65, 0xa5, 0xa0, 0x1c, 0xe9,
+ 0x5a, 0x17, 0x3f, 0xec, 0x91, 0xb2, 0x39, 0xc0,
+ 0x74, 0xfc, 0xc0, 0x8b, 0x74, 0x7e, 0x57, 0x58,
+ 0x36, 0x84, 0xa7, 0xe0, 0x44, 0x0a, 0x94, 0x91,
+ 0x19, 0x28, 0x42, 0x37, 0x7f, 0xee, 0x99, 0xdf,
+ 0xed, 0x81, 0x77, 0xfb, 0x40, 0xcf, 0xa1, 0x6a,
+ 0x56, 0x6f, 0xb8, 0x29, 0xdf, 0xf6, 0xa6, 0x29,
+ 0xfb, 0x58, 0xcb, 0x73, 0x46, 0x46, 0x4f, 0x7b,
+ 0x08, 0xee, 0x15, 0xec, 0x4f, 0x27, 0x94, 0x2b,
+ 0x3d, 0xf6, 0xea, 0xcf, 0x01, 0x9a, 0xb9, 0xa1,
+ 0x20, 0x27, 0x8b, 0x49, 0xf7, 0x81, 0x0b, 0xa4,
+ 0x05, 0x00, 0xe7, 0x5c, 0xa0, 0xb9, 0xd6, 0x7c,
+ 0x86, 0x23, 0x7a, 0xd8, 0x8c, 0xb4, 0xed, 0x23,
+ 0x90, 0xb1, 0x1d, 0x6c, 0x0a, 0x07, 0x2a, 0x6a,
+ 0x01, 0xbf, 0x22, 0x41, 0x61, 0x91, 0x68, 0x1b,
+ 0xff, 0xee, 0x22, 0x09, 0x36, 0x01, 0x9a, 0x47,
+ 0xc0, 0x69, 0xac, 0xc8, 0x9c, 0xee, 0xa0, 0x07,
+ 0x39, 0x36, 0x89, 0xd7, 0xd5, 0x44, 0x63, 0xf8,
+ 0x60, 0x5c, 0xe6, 0xee, 0x16, 0x3f, 0xf8, 0x28,
+ 0x82, 0x31, 0x02, 0x70, 0xb4, 0x60, 0xdb, 0x6d,
+ 0xbe, 0x06, 0x8f, 0x1d, 0x00, 0x82, 0x30, 0x05,
+ 0x72, 0x90, 0x30, 0x0e, 0xa2, 0xf6, 0x46, 0x3a,
+ 0xc6, 0x18, 0xa7, 0x6a, 0x2a, 0x70, 0x80, 0xa1,
+ 0xdb, 0x23, 0xfe, 0x26, 0x13, 0x64, 0x91, 0x42,
+ 0xc7, 0xd5, 0x25, 0x1d, 0x48, 0xb0, 0x4d, 0xe6,
+ 0xb8, 0xa3, 0x00, 0xb7, 0xf4, 0xe4, 0x29, 0xe8,
+ 0xb8, 0x58, 0xff, 0x1a, 0x33, 0x29, 0xc9, 0x01,
+ 0x86, 0x46, 0x04, 0x63, 0xfb, 0xe8, 0xcc, 0x32,
+ 0x08, 0x26, 0xcf, 0xb9, 0x89, 0xe3, 0x04, 0xc2,
+ 0x7c, 0xff, 0x9a, 0x0b, 0x62, 0x24, 0x07, 0xd9,
+ 0x89, 0x81, 0xb3, 0xeb, 0x02, 0x6e, 0x87, 0x58,
+ 0x98, 0xfe, 0x9a, 0x36, 0x3f, 0x05, 0x0d, 0x02,
+ 0x50, 0x62, 0x6c, 0xff, 0x80, 0xcb, 0x69, 0xd6,
+ 0x57, 0x7e, 0xe4, 0x0d, 0xcf, 0xac, 0x83, 0x2d,
+ 0x89, 0xf8, 0x9b, 0x2b, 0x18, 0x07, 0x49, 0x85,
+ 0x8d, 0xb3, 0xee, 0xca, 0x20, 0xfb, 0xbd, 0x9e,
+ 0x22, 0xdc, 0x07, 0xdf, 0xc8, 0xa8, 0xa3, 0xe7,
+ 0xed, 0x28, 0xfa, 0xa8, 0xde, 0x3e, 0xb6, 0x47,
+ 0x8f, 0xb0, 0x8c, 0xa6, 0x4c, 0xa5, 0x6e, 0x82,
+ 0x60, 0x9d, 0x0f, 0x31, 0x2a, 0x01, 0x00, 0xba,
+ 0x00, 0xc0, 0x6e, 0xe8, 0x68, 0x59, 0xa1, 0x8a,
+ 0x16, 0x4e, 0x10, 0x88, 0x8b, 0xe7, 0xe5, 0x62,
+ 0xe6, 0xf2, 0x5d, 0x3f, 0xae, 0x10, 0xa9, 0xe9,
+ 0x80, 0x82, 0x15, 0xa3, 0x0a, 0x93, 0x22, 0x19,
+ 0xa1, 0x08, 0x06, 0x4f, 0x3c, 0x14, 0xb7, 0xde,
+ 0x81, 0x5c, 0xfb, 0xc9, 0x48, 0x3c, 0xaa, 0x42,
+ 0xdf, 0xac, 0x24, 0xa7, 0x11, 0x8a, 0x6c, 0xf4,
+ 0xc2, 0x82, 0xa7, 0x4c, 0x36, 0x13, 0xa7, 0xbf,
+ 0x42, 0xdb, 0xe2, 0xe2, 0x14, 0x56, 0x10, 0x2e,
+ 0x74, 0x77, 0x0b, 0x1f, 0xaf, 0xce, 0x5b, 0x3b,
+ 0xa4, 0x1e, 0x7e, 0x44, 0xae, 0x66, 0x93, 0x3c,
+ 0x26, 0x80, 0xe9, 0x7f, 0xc0, 0x32, 0xed, 0x60,
+ 0x0c, 0xa7, 0x88, 0x95, 0x81, 0x9a, 0x75, 0x84,
+ 0x6c, 0xf6, 0x42, 0xd8, 0xff, 0x54, 0x20, 0xa8,
+ 0xdd, 0x89, 0x94, 0xf0, 0x65, 0x88, 0x38, 0x1b,
+ 0x7f, 0x43, 0xf2, 0xdf, 0xd0, 0xc8, 0xa7, 0xf5,
+ 0x4d, 0x65, 0xfd, 0xa0, 0x5d, 0x60, 0x22, 0x13,
+ 0xb8, 0x07, 0x84, 0xb4, 0x5b, 0xad, 0x90, 0x14,
+ 0x7d, 0x45, 0xc5, 0xb0, 0x07, 0x01, 0xf8, 0xfe,
+ 0x4e, 0xe0, 0x29, 0xb1, 0xb0, 0x58, 0x6d, 0xae,
+ 0x14, 0x0d, 0x43, 0x90, 0x2b, 0xda, 0x6d, 0x65,
+ 0xfd, 0xc9, 0x59, 0x62, 0x18, 0x27, 0x0e, 0x97,
+ 0x29, 0xc3, 0xaa, 0xa6, 0x65, 0xfa, 0x52, 0x02,
+ 0xa1, 0xde, 0x52, 0x08, 0x15, 0xa9, 0x8f, 0xf0,
+ 0x57, 0x20, 0xf7, 0x62, 0x5c, 0xfe, 0xf5, 0xa6,
+ 0x3f, 0x6e, 0x8d, 0x97, 0xef, 0x98, 0x63, 0xf3,
+ 0x32, 0x42, 0xbe, 0xf7, 0x26, 0xdf, 0x4a, 0x15,
+ 0xcb, 0x4a, 0x42, 0x20, 0xd3, 0xe8, 0xc8, 0x35,
+ 0x44, 0xa6, 0xcf, 0x61, 0xc8, 0x82, 0x52, 0x02,
+ 0x66, 0xdf, 0x48, 0x9b, 0xb4, 0x1e, 0x16, 0x4e,
+ 0x81, 0x9c, 0x83, 0xc0, 0xc6, 0x2d, 0x3b, 0x4a,
+ 0xa0, 0x21, 0x5f, 0xf2, 0x59, 0x04, 0x74, 0x04,
+ 0x7d, 0xb3, 0x33, 0x34, 0xee, 0xb4, 0x2e, 0x75,
+ 0xf9, 0x59, 0xee, 0x53, 0x80, 0xb9, 0x12, 0xe0,
+ 0x1d, 0x72, 0x68, 0xcd, 0xb2, 0xc0, 0x03, 0x0e,
+ 0x6d, 0xc6, 0x41, 0xbe, 0x54, 0x1f, 0xf9, 0xa4,
+ 0x44, 0x13, 0x26, 0x0b, 0x7e, 0x64, 0x40, 0xe7,
+ 0x10, 0xc3, 0x90, 0x75, 0xdc, 0xac, 0x90, 0xc6,
+ 0x13, 0x37, 0xb8, 0x1a, 0xdf, 0x0e, 0x81, 0x96,
+ 0x67, 0x6c, 0x87, 0x79, 0x15, 0xb1, 0xd6, 0x77,
+ 0x42, 0x7b, 0xf8, 0x03, 0x16, 0xfe, 0x2e, 0x4d,
+ 0x94, 0xcc, 0x13, 0x17, 0x34, 0x02, 0x41, 0xf8,
+ 0x96, 0x90, 0x49, 0xf8, 0x2c, 0x7b, 0x0d, 0x5b,
+ 0x1e, 0xc3, 0xd6, 0x81, 0x56, 0x41, 0xb8, 0x6d,
+ 0x04, 0xc7, 0xb9, 0x1f, 0x01, 0xdf, 0xde, 0xb6,
+ 0xb7, 0x63, 0xc0, 0xb9, 0xe4, 0xa4, 0x4c, 0x3e,
+ 0xfc, 0x0b, 0xcf, 0xba, 0xc2, 0x59, 0x91, 0x30,
+ 0x3a, 0xc4, 0xb0, 0x0c, 0x5c, 0x55, 0x0b, 0x9c,
+ 0x8c, 0x80, 0x41, 0x1c, 0x90, 0xb4, 0xe0, 0xf0,
+ 0x0d, 0xf2, 0x0a, 0x03, 0x6e, 0xb0, 0x46, 0xe7,
+ 0xf9, 0x27, 0x05, 0x53, 0x79, 0xe6, 0x59, 0xa6,
+ 0x23, 0x1e, 0xd1, 0x18, 0xc7, 0xa9, 0xa4, 0x39,
+ 0xc0, 0xf0, 0x0b, 0xb0, 0x3d, 0x43, 0xbd, 0x33,
+ 0x04, 0x41, 0xb1, 0x47, 0x94, 0xf1, 0x91, 0xa5,
+ 0x1b, 0xe4, 0x53, 0x24, 0x0c, 0x82, 0xc7, 0xe9,
+ 0x63, 0x14, 0x7f, 0x99, 0xc7, 0xe6, 0xf3, 0x11,
+ 0xab, 0x88, 0x20, 0x74, 0x97, 0x88, 0x97, 0x04,
+ 0x04, 0x98, 0xf8, 0x85, 0x8b, 0xfe, 0x23, 0x6d,
+ 0x32, 0x9b, 0x68, 0x64, 0x07, 0x2c, 0x02, 0x81,
+ 0x9e, 0x1a, 0xe1, 0x6e, 0x32, 0x9d, 0xf4, 0xa6,
+ 0x42, 0xec, 0xbe, 0x01, 0xd3, 0x06, 0xa1, 0x77,
+ 0x82, 0x18, 0x19, 0x7d, 0xfe, 0x17, 0x33, 0xae,
+ 0x08, 0x42, 0xe7, 0xa7, 0x63, 0x85, 0x66, 0x60,
+ 0x0e, 0x18, 0x0c, 0x03, 0x16, 0x01, 0x42, 0x41,
+ 0xa6, 0xc4, 0x37, 0x7f, 0x14, 0x05, 0xb9, 0xa5,
+ 0x21, 0x4d, 0x2e, 0x88, 0xc9, 0x33, 0xd1, 0x14,
+ 0x68, 0x10, 0xa5, 0x36, 0x57, 0x59, 0x04, 0xc8,
+ 0x08, 0xc9, 0xdf, 0x4e, 0xb2, 0x1b, 0xe1, 0x70,
+ 0x06, 0xee, 0x9c, 0x20, 0x2b, 0x9d, 0x64, 0x28,
+ 0xd9, 0x4b, 0x98, 0x60, 0x58, 0x15, 0xb8, 0x0b,
+ 0x11, 0x76, 0x55, 0x02, 0x61, 0xff, 0x80, 0x99,
+ 0x8d, 0x32, 0x8e, 0x03, 0x24, 0x0a, 0x00, 0x53,
+ 0xf5, 0x41, 0xa0, 0x49, 0x88, 0x27, 0x72, 0x79,
+ 0x0b, 0x0c, 0x00, 0x82, 0x5b, 0x7d, 0x80, 0x34,
+ 0x9d, 0x0e, 0x79, 0x1c, 0x13, 0x7c, 0x6b, 0x08,
+ 0xe6, 0x69, 0xa8, 0x50, 0x08, 0x2d, 0x9e, 0x86,
+ 0xf8, 0xcb, 0x0c, 0x9e, 0xd8, 0xe7, 0x20, 0xbd,
+ 0xc8, 0xcb, 0x24, 0x40, 0x16, 0x4f, 0xb8, 0xb4,
+ 0xef, 0x51, 0xe2, 0x68, 0x97, 0xe8, 0x4e, 0xa8,
+ 0x22, 0x36, 0xf8, 0xae, 0x91, 0xb8, 0x87, 0x78,
+ 0xe1, 0x91, 0x7e, 0xbe, 0x04, 0x04, 0x3e, 0x12,
+ 0x11, 0xbb, 0xf9, 0x43, 0x20, 0xf4, 0x41, 0x0b,
+ 0xa2, 0xec, 0x06, 0x8e, 0x35, 0x89, 0x87, 0xec,
+ 0xa9, 0x3b, 0xfd, 0x39, 0x4e, 0xbf, 0x51, 0xf6,
+ 0x5f, 0xd4, 0x28, 0xc7, 0xf5, 0x0c, 0x31, 0xfb,
+ 0x19, 0x8e, 0xf3, 0xce, 0x26, 0x5b, 0x7c, 0x84,
+ 0xeb, 0xeb, 0x5f, 0x27, 0xb5, 0x19, 0x5c, 0xec,
+ 0x5a, 0x07, 0x2b, 0x1e, 0x05, 0xa7, 0x3c, 0x80,
+ 0x65, 0x80, 0xf8, 0x1c, 0xaa, 0x7a, 0x16, 0x4f,
+ 0x63, 0x9c, 0x2b, 0xf6, 0x26, 0x3a, 0xf8, 0x67,
+ 0xc9, 0xe2, 0x60, 0x13, 0x1f, 0xc2, 0x98, 0xef,
+ 0xc5, 0xe4, 0x61, 0x33, 0x99, 0xe3, 0x22, 0x06,
+ 0x78, 0xf4, 0x09, 0xbf, 0xae, 0x43, 0x69, 0x33,
+ 0x54, 0x7c, 0x0c, 0x9e, 0x28, 0xa3, 0x85, 0x79,
+ 0x42, 0x5b, 0x5b, 0x50, 0x96, 0xe4, 0xe4, 0xec,
+ 0x3d, 0x9e, 0x39, 0x95, 0x71, 0x04, 0xd3, 0x92,
+ 0x10, 0x90, 0x77, 0xf0, 0xa5, 0xbf, 0xf8, 0x33,
+ 0x7c, 0x0b, 0x48, 0x53, 0xfd, 0xd0, 0x39, 0xd7,
+ 0x98, 0x4c, 0x9d, 0x7a, 0x23, 0x0f, 0xf8, 0x1c,
+ 0xd3, 0xfc, 0x41, 0x14, 0x82, 0xab, 0xce, 0x76,
+ 0x1e, 0xca, 0x8c, 0x83, 0xf3, 0xc8, 0x3b, 0x82,
+ 0x48, 0x5b, 0xf9, 0x9e, 0x03, 0xaa, 0x2c, 0x05,
+ 0xbe, 0x03, 0xc4, 0x63, 0xd7, 0x82, 0xdb, 0xfb,
+ 0xb0, 0x57, 0xd9, 0x0a, 0x04, 0x8a, 0x92, 0x23,
+ 0x0a, 0xee, 0x79, 0x99, 0xa0, 0x00, 0x32, 0xcb,
+ 0x84, 0x94, 0xb2, 0xe6, 0xc5, 0x6d, 0xd5, 0xb9,
+ 0x0f, 0xb9, 0x2e, 0x22, 0xde, 0xc5, 0x8d, 0xbf,
+ 0xaf, 0xe4, 0x2b, 0xed, 0x30, 0x98, 0x7d, 0xd0,
+ 0x73, 0xbe, 0xab, 0x89, 0xca, 0xd4, 0xc0, 0x79,
+ 0xf2, 0x8a, 0x88, 0x34, 0xe6, 0x92, 0x2e, 0xaa,
+ 0x45, 0xb2, 0x09, 0x85, 0x6d, 0xd2, 0x90, 0x98,
+ 0xed, 0x8c, 0x46, 0xfe, 0x08, 0x81, 0xcf, 0xa3,
+ 0x66, 0x7c, 0xfb, 0x1f, 0xdd, 0x3e, 0xc6, 0xd6,
+ 0xef, 0xe0, 0x8c, 0xab, 0xeb, 0x79, 0x72, 0x83,
+ 0x40, 0x0e, 0xb9, 0x72, 0x86, 0x3f, 0xaf, 0xfd,
+ 0x87, 0xeb, 0xed, 0x6f, 0xfb, 0x2f, 0x9b, 0xfd,
+ 0x10, 0x56, 0x5a, 0x09, 0x04, 0x2b, 0x80, 0x6a,
+ 0x20, 0xee, 0xfa, 0xdc, 0x0e, 0x9c, 0x2b, 0x03,
+ 0x4f, 0x7d, 0x44, 0xe1, 0xff, 0x70, 0xb1, 0xf7,
+ 0x7e, 0xae, 0x1f, 0xe4, 0x3b, 0x87, 0xf4, 0x42,
+ 0xdf, 0xdd, 0xb8, 0x95, 0xce, 0xcc, 0xa1, 0x54,
+ 0x47, 0x6a, 0xb1, 0x0c, 0x82, 0x4c, 0x26, 0x51,
+ 0x16, 0xe7, 0x42, 0x03, 0xb4, 0x07, 0x02, 0xd9,
+ 0x4c, 0xc1, 0x38, 0x40, 0xac, 0x0c, 0x26, 0xd3,
+ 0x1c, 0xa8, 0x42, 0x45, 0x28, 0x25, 0x3a, 0xe5,
+ 0xed, 0x87, 0x13, 0x74, 0x0b, 0x24, 0xe5, 0xce,
+ 0x63, 0x33, 0xa0, 0x39, 0x4b, 0x60, 0x24, 0x32,
+ 0x9f, 0x0a, 0x59, 0xb0, 0xea, 0x64, 0x92, 0xe0,
+ 0x08, 0x20, 0x46, 0x12, 0x08, 0x14, 0x85, 0x9e,
+ 0x59, 0x41, 0x74, 0x81, 0x10, 0x0b, 0x8e, 0xc7,
+ 0x42, 0x1c, 0xc9, 0xc6, 0xc5, 0x00, 0xa0, 0x37,
+ 0xca, 0x9c, 0x2d, 0x3b, 0x67, 0x03, 0x9d, 0x05,
+ 0x88, 0xca, 0x64, 0xde, 0x30, 0x5c, 0xaf, 0xa8,
+ 0x32, 0xc9, 0x24, 0x05, 0x73, 0xf0, 0x0a, 0x69,
+ 0x80, 0x40, 0x19, 0x63, 0x2e, 0x02, 0xd9, 0x01,
+ 0x89, 0x92, 0xf7, 0x03, 0x5c, 0xf6, 0x47, 0xcb,
+ 0x74, 0x8a, 0x66, 0xed, 0x12, 0x84, 0xca, 0x4c,
+ 0xe0, 0x76, 0xf9, 0x58, 0x88, 0x3f, 0x54, 0x77,
+ 0x3d, 0x69, 0x99, 0xa7, 0x91, 0xa8, 0x6f, 0xd6,
+ 0x09, 0x0b, 0x63, 0x38, 0x23, 0xbf, 0x7c, 0x19,
+ 0xca, 0x2f, 0x60, 0x30, 0x3c, 0x0e, 0x06, 0x03,
+ 0x0f, 0xff, 0x00, 0xc3, 0xff, 0x60, 0x20, 0x88,
+ 0xb8, 0x5d, 0xbd, 0xc4, 0x43, 0xb8, 0xde, 0x85,
+ 0x0f, 0xf5, 0xa2, 0x77, 0x9a, 0xe8, 0x1a, 0x23,
+ 0xd4, 0x17, 0x48, 0xbb, 0x01, 0xbb, 0x48, 0xe3,
+ 0x65, 0x9b, 0xa0, 0x59, 0x23, 0x22, 0x06, 0x98,
+ 0x1f, 0x01, 0x93, 0x5e, 0xa0, 0x53, 0x96, 0x7a,
+ 0x91, 0x89, 0x84, 0xf2, 0x09, 0x53, 0xd1, 0x1e,
+ 0x66, 0xd4, 0x21, 0x1c, 0x3d, 0x0a, 0x62, 0xd1,
+ 0xe4, 0x41, 0x84, 0x7d, 0x10, 0x80, 0x33, 0x75,
+ 0x80, 0x24, 0x12, 0x26, 0x0b, 0xc7, 0xdc, 0xd2,
+ 0x15, 0xe7, 0x3f, 0xb9, 0x79, 0xcf, 0xee, 0xbe,
+ 0x73, 0xf9, 0x67, 0x9c, 0xfe, 0x51, 0xd3, 0xbf,
+ 0xb6, 0x79, 0xce, 0x2c, 0xde, 0x38, 0x23, 0x87,
+ 0x9c, 0x3e, 0x41, 0xf0, 0x42, 0x9d, 0x82, 0x8b,
+ 0x73, 0x9d, 0x1a, 0xec, 0x10, 0x42, 0x8d, 0xea,
+ 0x96, 0x05, 0x7f, 0x9a, 0x4a, 0xdd, 0x17, 0x10,
+ 0x55, 0x06, 0xc2, 0xdd, 0x0e, 0x10, 0x31, 0xc7,
+ 0x6c, 0x65, 0x10, 0x16, 0x03, 0x65, 0x6a, 0xc2,
+ 0xd3, 0x06, 0x90, 0x30, 0xe2, 0x70, 0x4e, 0x78,
+ 0xd6, 0x0a, 0xee, 0x34, 0x08, 0x5b, 0xd2, 0x41,
+ 0x39, 0xc2, 0x14, 0x44, 0x30, 0x53, 0x50, 0x54,
+ 0x37, 0x08, 0x7d, 0x12, 0x42, 0x2e, 0x51, 0xf4,
+ 0x2e, 0x10, 0x34, 0x03, 0xa4, 0x6b, 0x00, 0xc7,
+ 0x6c, 0x70, 0xba, 0xc7, 0x74, 0x0c, 0x90, 0x6f,
+ 0x0b, 0xbc, 0x98, 0x14, 0xe7, 0x15, 0x60, 0x38,
+ 0x7e, 0x47, 0xef, 0x5f, 0x91, 0x21, 0x07, 0xda,
+ 0x10, 0x77, 0x21, 0x30, 0xba, 0x55, 0x34, 0xc4,
+ 0x07, 0x08, 0x8c, 0x81, 0xda, 0x1b, 0x00, 0x75,
+ 0x88, 0x48, 0x0e, 0xaf, 0x9c, 0x26, 0x4b, 0xe5,
+ 0xa0, 0x82, 0xb7, 0x84, 0x0a, 0xb5, 0x38, 0x4e,
+ 0xa4, 0xc0, 0x06, 0x4f, 0xf3, 0xa5, 0x92, 0x94,
+ 0x23, 0x5b, 0x87, 0x63, 0x50, 0x2d, 0x00, 0x02,
+ 0x08, 0x95, 0x14, 0x80, 0x77, 0x24, 0x00, 0x32,
+ 0xd3, 0x10, 0x0d, 0x87, 0x5d, 0x37, 0x15, 0xba,
+ 0x0f, 0x00, 0x61, 0x86, 0xb8, 0x02, 0xa3, 0x46,
+ 0x76, 0x3a, 0x2c, 0x8c, 0x2a, 0x77, 0x48, 0x30,
+ 0xe3, 0xd8, 0xd3, 0x8a, 0xbb, 0xd5, 0x01, 0x05,
+ 0x90, 0x44, 0xdd, 0x96, 0x72, 0x85, 0x52, 0x4c,
+ 0x45, 0x90, 0xa3, 0x0b, 0xbc, 0x57, 0x00, 0x15,
+ 0x5a, 0xd0, 0x29, 0xee, 0x9f, 0xee, 0x50, 0x35,
+ 0x0a, 0xee, 0xe9, 0x48, 0x69, 0x84, 0xa2, 0x10,
+ 0x70, 0x88, 0x4d, 0x32, 0x36, 0x33, 0x9d, 0xd4,
+ 0x82, 0x15, 0xe2, 0x80, 0x36, 0x40, 0x78, 0x0b,
+ 0xa0, 0xa1, 0x9f, 0xf7, 0xf2, 0xdd, 0xe0, 0x71,
+ 0x05, 0x50, 0x85, 0xec, 0x93, 0xa8, 0x1b, 0x24,
+ 0x18, 0x80, 0x15, 0x04, 0x90, 0x32, 0xce, 0xf0,
+ 0xad, 0xb4, 0x1e, 0x0b, 0x1d, 0x33, 0x86, 0xdb,
+ 0xff, 0x63, 0x10, 0x50, 0xf0, 0x6c, 0x70, 0x8f,
+ 0x2b, 0x14, 0x06, 0x40, 0xdd, 0x3a, 0x44, 0x05,
+ 0x7f, 0x69, 0xce, 0xb4, 0x99, 0x51, 0x0d, 0xb6,
+ 0x44, 0xc9, 0x64, 0x74, 0x05, 0x4e, 0x11, 0x87,
+ 0xd0, 0x5a, 0x20, 0x54, 0xc6, 0x4a, 0x5d, 0x5a,
+ 0x60, 0x38, 0x5a, 0x88, 0x25, 0x13, 0x94, 0x4b,
+ 0x1c, 0x43, 0x0c, 0xe1, 0xeb, 0x91, 0x96, 0xd6,
+ 0xb0, 0xc6, 0x1e, 0xf2, 0x3b, 0x25, 0x7a, 0x5a,
+ 0xc7, 0xfb, 0x42, 0xbb, 0xf5, 0x60, 0x25, 0x1f,
+ 0xb6, 0x93, 0xbf, 0x4f, 0xc2, 0x53, 0x0a, 0xa0,
+ 0xb9, 0x6e, 0x24, 0x8e, 0xfd, 0x30, 0x0b, 0x7c,
+ 0xf4, 0xc2, 0xd9, 0x3d, 0xb1, 0x18, 0xfe, 0xa6,
+ 0xea, 0x79, 0xfb, 0xfb, 0x96, 0x7e, 0xcc, 0xc7,
+ 0xf3, 0x22, 0xbb, 0x69, 0x48, 0xab, 0x9d, 0xf7,
+ 0x03, 0xad, 0x2a, 0xc4, 0x41, 0x36, 0xc0, 0xab,
+ 0x15, 0x08, 0x24, 0x22, 0x61, 0x16, 0x7b, 0x26,
+ 0x2c, 0xa4, 0x10, 0x98, 0x4d, 0xd3, 0x16, 0x01,
+ 0x97, 0xcc, 0x7e, 0xe7, 0x56, 0x81, 0x14, 0x7b,
+ 0x9a, 0x4e, 0x75, 0x4e, 0x11, 0x4f, 0xcb, 0xd0,
+ 0xc7, 0x02, 0x21, 0x13, 0xdb, 0x3c, 0x2c, 0x27,
+ 0x98, 0x23, 0x81, 0x86, 0x00, 0xe0, 0x73, 0xee,
+ 0xe0, 0x8c, 0xfd, 0xa1, 0x75, 0xbe, 0xe1, 0x11,
+ 0x8f, 0xf3, 0x1f, 0x73, 0xfc, 0xc7, 0xde, 0xa0,
+ 0x82, 0x03, 0x2f, 0xcc, 0x65, 0xbb, 0xaf, 0x63,
+ 0x3a, 0xb8, 0x72, 0x1b, 0x7b, 0x3e, 0x73, 0xd8,
+ 0x07, 0x80, 0xba, 0x90, 0xc3, 0x40, 0xa8, 0x88,
+ 0xd9, 0xe2, 0xfa, 0x17, 0x7d, 0xcc, 0x05, 0xb7,
+ 0xfb, 0xeb, 0x77, 0xdc, 0x30, 0x50, 0x3f, 0xc0,
+ 0x77, 0x3e, 0xea, 0x0d, 0xb7, 0xf7, 0xac, 0x75,
+ 0xee, 0x00, 0x90, 0x21, 0xf0, 0x15, 0x3c, 0x26,
+ 0x7d, 0xcb, 0x09, 0x88, 0x67, 0x88, 0x70, 0x5d,
+ 0xb1, 0x4a, 0x56, 0xdf, 0xb6, 0x2d, 0xdb, 0x11,
+ 0xe5, 0x40, 0xfb, 0x49, 0xdd, 0x8e, 0x84, 0x19,
+ 0x2a, 0x80, 0x83, 0xfb, 0x54, 0x3b, 0xf8, 0xda,
+ 0x5a, 0x77, 0x14, 0x86, 0x3e, 0x99, 0x34, 0x8a,
+ 0x74, 0x47, 0x69, 0x9a, 0x2b, 0x0a, 0x6c, 0x8e,
+ 0xc7, 0x0d, 0xe3, 0x11, 0xf3, 0x74, 0x26, 0x68,
+ 0x93, 0x40, 0x19, 0x77, 0x62, 0x62, 0xda, 0xe3,
+ 0x04, 0xbb, 0x64, 0x6a, 0x5c, 0xa7, 0xf3, 0x0a,
+ 0x63, 0x28, 0x26, 0x5f, 0x98, 0x14, 0x83, 0xd2,
+ 0xeb, 0x67, 0xac, 0x79, 0x42, 0xae, 0xae, 0x16,
+ 0xfe, 0xb1, 0x09, 0x87, 0xff, 0x01, 0x63, 0x84,
+ 0x18, 0x9c, 0x3b, 0x9c, 0x67, 0x0d, 0xff, 0x01,
+ 0x96, 0xb0, 0xc8, 0x20, 0x91, 0x88, 0x48, 0x3e,
+ 0x77, 0x86, 0xef, 0x9c, 0xfd, 0xcb, 0x4d, 0x02,
+ 0x6e, 0x8c, 0x80, 0x48, 0x2b, 0x0e, 0x76, 0xe8,
+ 0xc1, 0x04, 0x2b, 0xe5, 0xff, 0x6e, 0xfe, 0x60,
+ 0x9a, 0x7e, 0x55, 0xf2, 0x0f, 0x95, 0x29, 0xbb,
+ 0xf3, 0x02, 0x2a, 0xf9, 0x58, 0xdd, 0x3e, 0x47,
+ 0xc6, 0xe8, 0x90, 0x85, 0x73, 0xcc, 0x1b, 0x29,
+ 0xd7, 0xe2, 0x4f, 0x60, 0x18, 0x06, 0x98, 0xcb,
+ 0x18, 0xb6, 0x89, 0x01, 0x69, 0x8e, 0x38, 0x42,
+ 0xbf, 0x72, 0x52, 0xdf, 0x6c, 0x7c, 0xb7, 0xf6,
+ 0x6f, 0x61, 0xa1, 0x58, 0x82, 0xa7, 0xfc, 0x26,
+ 0x1a, 0x10, 0x88, 0xb7, 0xf6, 0x07, 0x61, 0xf3,
+ 0x88, 0x88, 0x3e, 0xcf, 0x22, 0xde, 0xe7, 0x79,
+ 0x8e, 0x00, 0x63, 0x7c, 0x9c, 0xea, 0x9b, 0x7c,
+ 0x0b, 0x22, 0x0f, 0x06, 0x9c, 0xa2, 0x1b, 0xa6,
+ 0x20, 0x95, 0x08, 0x1a, 0x73, 0xc6, 0x06, 0x68,
+ 0x09, 0x01, 0x9e, 0x09, 0xc1, 0x61, 0x81, 0x90,
+ 0x1c, 0x8e, 0x91, 0x00, 0x03, 0x0f, 0x79, 0xcc,
+ 0xcd, 0xfe, 0x40, 0xb2, 0xc8, 0x14, 0x04, 0x5f,
+ 0xd1, 0x49, 0x4c, 0xce, 0x0a, 0x65, 0x54, 0x11,
+ 0x16, 0xfb, 0xc1, 0x4c, 0x3d, 0xb1, 0x11, 0x6f,
+ 0x71, 0x88, 0xb9, 0xdc, 0x49, 0x96, 0xfc, 0xe3,
+ 0xed, 0x93, 0x4d, 0x31, 0x07, 0xcc, 0xfe, 0xcb,
+ 0xe0, 0xe5, 0x31, 0xfc, 0xb3, 0xec, 0x3f, 0x2c,
+ 0xdb, 0x77, 0x56, 0xc4, 0xdf, 0x01, 0xd1, 0x31,
+ 0xe6, 0x1c, 0xa7, 0xde, 0x61, 0x53, 0x1e, 0x0e,
+ 0xc6, 0x77, 0xe5, 0xb2, 0xba, 0x47, 0xcc, 0x26,
+ 0x43, 0xaa, 0x9f, 0x81, 0xa7, 0x2b, 0xe3, 0x32,
+ 0x1d, 0x45, 0x3c, 0xef, 0xbc, 0x55, 0x21, 0x44,
+ 0x4f, 0x4e, 0x5b, 0x52, 0x43, 0x14, 0x82, 0xbf,
+ 0xa2, 0x36, 0xd3, 0xcf, 0x9c, 0xdc, 0xe9, 0xfe,
+ 0x72, 0x32, 0x45, 0x80, 0x46, 0x5e, 0xad, 0x9b,
+ 0xa7, 0x66, 0xca, 0xf7, 0xcb, 0x62, 0x19, 0x7e,
+ 0x1f, 0xec, 0x3f, 0x87, 0xfb, 0x77, 0x35, 0x52,
+ 0x15, 0xf8, 0x06, 0x94, 0x50, 0x20, 0x0d, 0x30,
+ 0x7f, 0x31, 0x94, 0x1d, 0x4e, 0x53, 0xca, 0x12,
+ 0x16, 0xcd, 0x64, 0x45, 0xbd, 0x45, 0x83, 0x94,
+ 0x7f, 0x00, 0x41, 0xf0, 0xa6, 0x90, 0x72, 0x8b,
+ 0x4c, 0x97, 0xa8, 0x1b, 0x94, 0xd2, 0x0c, 0x15,
+ 0x00, 0x52, 0x19, 0x10, 0x23, 0x5e, 0x57, 0x3c,
+ 0x64, 0x81, 0x96, 0x03, 0x85, 0x7b, 0xf4, 0xb2,
+ 0x5b, 0xea, 0xf5, 0x57, 0xdf, 0x51, 0x90, 0xb7,
+ 0x5c, 0xa2, 0x77, 0xce, 0xa0, 0xd9, 0xae, 0x1e,
+ 0xd2, 0x0a, 0x9e, 0xa0, 0xa7, 0xfa, 0x69, 0x73,
+ 0x84, 0x08, 0x99, 0x24, 0xf2, 0x32, 0x8a, 0x8e,
+ 0x5c, 0xa6, 0xe8, 0x95, 0x3b, 0xaa, 0x38, 0xd8,
+ 0xb4, 0x31, 0xb6, 0xff, 0xd6, 0x5d, 0xde, 0xa0,
+ 0x06, 0x6c, 0x82, 0x69, 0x5d, 0xf2, 0x12, 0x52,
+ 0x0d, 0x01, 0x1d, 0xc3, 0x46, 0xfa, 0x77, 0xad,
+ 0xb8, 0x5d, 0xe8, 0xdc, 0x17, 0x7a, 0x35, 0x00,
+ 0xb6, 0x90, 0xc2, 0x73, 0xb5, 0xf0, 0xd7, 0x28,
+ 0xf4, 0x22, 0x0b, 0x59, 0x0d, 0x8e, 0xb1, 0x03,
+ 0x63, 0x80, 0x89, 0x1a, 0x6a, 0xbe, 0x62, 0x08,
+ 0xcf, 0x01, 0x9e, 0x35, 0x82, 0x68, 0xad, 0xe8,
+ 0x5d, 0x4c, 0x5c, 0x91, 0x2b, 0x0d, 0x4b, 0x44,
+ 0xd3, 0x42, 0x20, 0x31, 0x58, 0x7d, 0x64, 0x11,
+ 0x73, 0x03, 0x66, 0xfc, 0x00, 0xcb, 0x20, 0x10,
+ 0x3a, 0x7f, 0x4d, 0x4e, 0xf4, 0x48, 0x33, 0x46,
+ 0x5a, 0xc4, 0xc7, 0x60, 0xb6, 0x10, 0x50, 0x54,
+ 0x2e, 0x46, 0x58, 0x5b, 0x81, 0x9a, 0x41, 0xc1,
+ 0x64, 0xb0, 0x03, 0x1c, 0x29, 0xe4, 0x42, 0xcf,
+ 0xae, 0x89, 0x87, 0x93, 0x00, 0x20, 0xa7, 0x12,
+ 0xdd, 0xe7, 0x4a, 0x12, 0xcf, 0xf3, 0x19, 0xde,
+ 0x9b, 0xbf, 0x45, 0xa6, 0xeb, 0x9c, 0x32, 0x1a,
+ 0x92, 0xdc, 0x6f, 0x85, 0x9f, 0x05, 0x09, 0x2c,
+ 0xa7, 0xd1, 0xda, 0x31, 0x72, 0x96, 0xdf, 0xea,
+ 0xa9, 0xcf, 0xbf, 0x26, 0x2c, 0x82, 0x08, 0x58,
+ 0x7c, 0x02, 0xf6, 0xdb, 0xa9, 0x2d, 0x92, 0xa5,
+ 0x69, 0x77, 0x97, 0x68, 0x59, 0xbb, 0x2a, 0xe2,
+ 0xd8, 0x1a, 0x84, 0x2a, 0xa0, 0x5f, 0x72, 0x97,
+ 0x08, 0x08, 0x25, 0xce, 0x17, 0x53, 0x9c, 0x3e,
+ 0x40, 0xe7, 0x2e, 0x6c, 0xb7, 0xc2, 0x40, 0x65,
+ 0xb5, 0x58, 0x09, 0x47, 0x66, 0x74, 0xcd, 0x06,
+ 0xa1, 0x94, 0xf2, 0xa0, 0x8c, 0xd0, 0x07, 0x09,
+ 0x6d, 0x65, 0xc8, 0x5a, 0x78, 0xc4, 0x00, 0x5a,
+ 0x60, 0x6a, 0x03, 0xed, 0x14, 0x01, 0x93, 0x06,
+ 0x20, 0x40, 0xb4, 0xe0, 0xda, 0x69, 0xc3, 0x56,
+ 0x3e, 0x24, 0x91, 0xd7, 0x8c, 0x26, 0x62, 0xfe,
+ 0x68, 0x4f, 0xa8, 0xac, 0x06, 0xe8, 0x5b, 0x84,
+ 0x82, 0x04, 0xe2, 0x6d, 0xaa, 0x29, 0x08, 0x31,
+ 0x8c, 0xc2, 0x08, 0x03, 0x8d, 0xb3, 0x2e, 0x72,
+ 0x62, 0x32, 0x99, 0xe1, 0xd8, 0x00, 0xa8, 0x4d,
+ 0x91, 0x8b, 0xf6, 0x69, 0x74, 0x3c, 0xc8, 0x4c,
+ 0x04, 0x02, 0xe8, 0x0e, 0x01, 0xb6, 0x9e, 0x84,
+ 0x3a, 0x80, 0x90, 0x18, 0xe0, 0xd8, 0x16, 0xcf,
+ 0xd7, 0x24, 0xfa, 0xbe, 0xe7, 0x3e, 0xf6, 0xa9,
+ 0x5d, 0xe3, 0xa2, 0x17, 0x3d, 0xe7, 0x04, 0x82,
+ 0x43, 0x47, 0x63, 0xc8, 0xae, 0x9d, 0x67, 0x62,
+ 0x10, 0xa8, 0x16, 0x89, 0xd2, 0x09, 0x20, 0x63,
+ 0x93, 0xf8, 0xcc, 0x07, 0xbf, 0x26, 0x03, 0x71,
+ 0xd2, 0x30, 0x80, 0x20, 0xfc, 0xa0, 0x4e, 0xe2,
+ 0x44, 0x17, 0x09, 0x27, 0x85, 0x9e, 0x08, 0x40,
+ 0x65, 0xf9, 0x9f, 0xdb, 0x3e, 0x67, 0xf6, 0x5b,
+ 0x64, 0x15, 0x8f, 0xed, 0xdf, 0x64, 0xfb, 0x76,
+ 0x9c, 0xfe, 0xe7, 0x36, 0xde, 0x03, 0xc4, 0x83,
+ 0xb7, 0xe6, 0x73, 0xfa, 0x00, 0x5c, 0x22, 0x12,
+ 0x52, 0x08, 0x5b, 0x89, 0x90, 0xcb, 0x0a, 0x00,
+ 0x33, 0xf9, 0x82, 0x2c, 0xdd, 0xed, 0x63, 0x27,
+ 0xf6, 0x44, 0x5b, 0xde, 0x40, 0x9d, 0xd7, 0x48,
+ 0x0e, 0x5f, 0xc1, 0x2b, 0x9c, 0x10, 0x52, 0xdb,
+ 0x1f, 0xf5, 0x85, 0x18, 0xe2, 0x14, 0x07, 0x38,
+ 0x5b, 0x05, 0xd2, 0x3b, 0xa3, 0x0a, 0xd8, 0x50,
+ 0xd8, 0xf1, 0xb4, 0x77, 0x3d, 0x7e, 0x84, 0xee,
+ 0x5b, 0x5f, 0x20, 0xa4, 0x4a, 0x9a, 0x20, 0x34,
+ 0x07, 0x68, 0x33, 0x01, 0x8a, 0xf4, 0xc0, 0x20,
+ 0x89, 0x20, 0x0a, 0xe0, 0x74, 0x02, 0x08, 0x60,
+ 0xa1, 0x6e, 0x7a, 0x86, 0x6e, 0x84, 0xbc, 0xc8,
+ 0x21, 0x2f, 0xf0, 0xa8, 0x4b, 0xa8, 0xc2, 0x19,
+ 0x92, 0x20, 0x84, 0x1f, 0xd9, 0x21, 0x06, 0x93,
+ 0x08, 0x18, 0x0c, 0xba, 0x45, 0xc5, 0x0a, 0x85,
+ 0x7f, 0x5b, 0x7d, 0xc0, 0x23, 0xb8, 0x57, 0x1d,
+ 0xbe, 0xa0, 0xe0, 0x65, 0xe1, 0x38, 0x02, 0xbf,
+ 0xf2, 0x42, 0x08, 0x5a, 0x69, 0xbf, 0xfb, 0xaa,
+ 0x75, 0x85, 0xbf, 0xd8, 0x61, 0x6e, 0xf3, 0xa8,
+ 0x62, 0x94, 0xa2, 0x74, 0xae, 0x2d, 0xe1, 0x38,
+ 0x5b, 0x21, 0x56, 0xc2, 0x9a, 0x6a, 0x81, 0xa6,
+ 0x05, 0x40, 0x6d, 0x9c, 0xb0, 0x8e, 0xe6, 0x9e,
+ 0x36, 0x9c, 0x70, 0x09, 0xa7, 0xf9, 0x0f, 0x29,
+ 0x80, 0xe8, 0xc2, 0xab, 0x6f, 0x42, 0x89, 0xc5,
+ 0x91, 0xcf, 0x1b, 0xc4, 0x65, 0x9e, 0x90, 0x1c,
+ 0xf7, 0xb4, 0x46, 0x1a, 0x96, 0x1c, 0x82, 0x87,
+ 0x30, 0x2d, 0xa5, 0x30, 0x8c, 0x31, 0x1c, 0x36,
+ 0xc9, 0x87, 0x94, 0x9b, 0xf0, 0x23, 0x26, 0xa3,
+ 0x68, 0x1e, 0x26, 0x7c, 0x66, 0x99, 0x99, 0x89,
+ 0xf2, 0xa6, 0xa5, 0x73, 0x84, 0x10, 0x1a, 0x69,
+ 0x20, 0x12, 0x2f, 0xe8, 0x05, 0xbc, 0xd7, 0x20,
+ 0x70, 0x16, 0xc3, 0x00, 0x84, 0x1c, 0x29, 0x09,
+ 0x35, 0x1e, 0x06, 0xe7, 0x06, 0x20, 0x37, 0x7f,
+ 0x14, 0x24, 0x5f, 0xe0, 0x8b, 0x77, 0xeb, 0x42,
+ 0x15, 0xd4, 0x01, 0x98, 0x08, 0x07, 0xf0, 0x2a,
+ 0x00, 0x54, 0xb6, 0xd2, 0x65, 0x54, 0x40, 0x85,
+ 0x7e, 0x18, 0x8c, 0xbe, 0x54, 0x20, 0x57, 0xdf,
+ 0x88, 0xcb, 0xe4, 0x62, 0xb2, 0x40, 0xb0, 0x4e,
+ 0x9b, 0xc4, 0x03, 0x4c, 0x1b, 0x82, 0x15, 0xf8,
+ 0x50, 0xb8, 0x4b, 0xac, 0x6c, 0xdb, 0xd0, 0x12,
+ 0xe7, 0xb5, 0x2a, 0xc9, 0xa8, 0x51, 0xb9, 0x6e,
+ 0xb8, 0x01, 0x54, 0xbb, 0x2b, 0x36, 0xe8, 0x84,
+ 0xcd, 0x4b, 0xf2, 0x85, 0x5f, 0x48, 0x8e, 0x11,
+ 0x46, 0x09, 0x47, 0x97, 0x62, 0xd3, 0x1c, 0xb3,
+ 0x38, 0x48, 0x14, 0x65, 0xb1, 0xe9, 0x33, 0x6e,
+ 0xc8, 0x70, 0x41, 0xb3, 0xa6, 0xb4, 0xf9, 0x02,
+ 0x2d, 0xfd, 0x86, 0x21, 0xec, 0x26, 0xc0, 0xc7,
+ 0x53, 0xf1, 0xb6, 0xc2, 0x21, 0x4e, 0x1a, 0xfe,
+ 0x31, 0xdd, 0xcd, 0xc4, 0xd3, 0xe2, 0xc3, 0xb0,
+ 0xf7, 0x0d, 0x6e, 0x70, 0x03, 0x0b, 0x79, 0x9a,
+ 0x32, 0x28, 0x29, 0xfd, 0x5f, 0x19, 0xe0, 0x3a,
+ 0x63, 0xbc, 0xe7, 0x24, 0xa3, 0xec, 0x7f, 0x61,
+ 0xfb, 0x1b, 0x9b, 0x73, 0x26, 0x53, 0xb8, 0x57,
+ 0x0d, 0x93, 0x95, 0xc0, 0x20, 0x8b, 0xa0, 0x9a,
+ 0x7d, 0x8f, 0x75, 0xb3, 0x75, 0x7d, 0x00, 0xc7,
+ 0x0b, 0x46, 0xb1, 0xf6, 0xc5, 0x4d, 0x30, 0xdd,
+ 0x38, 0x57, 0xcf, 0xfe, 0xe7, 0x2d, 0x61, 0x15,
+ 0x44, 0x08, 0x45, 0x55, 0xfe, 0x49, 0x06, 0xd5,
+ 0x40, 0xc7, 0x00, 0x61, 0x9d, 0xc6, 0xf4, 0x6f,
+ 0x1c, 0xcb, 0x52, 0xdf, 0xe0, 0x4e, 0x5b, 0xf6,
+ 0xc5, 0x15, 0x8c, 0x7e, 0xd5, 0xf7, 0x3f, 0xb5,
+ 0x7c, 0x82, 0x08, 0xaa, 0x69, 0xfb, 0xb8, 0xc2,
+ 0xbe, 0xee, 0x87, 0x0c, 0x78, 0x04, 0x83, 0xee,
+ 0xff, 0x2d, 0xfb, 0xbf, 0xdb, 0xbd, 0xc3, 0xf7,
+ 0x3f, 0xbb, 0xc1, 0xcc, 0xee, 0x61, 0x8f, 0xe0,
+ 0x42, 0xbd, 0xd2, 0x86, 0x4c, 0xc0, 0x14, 0xca,
+ 0x5c, 0x66, 0x3f, 0xb2, 0xb8, 0x0a, 0x73, 0x05,
+ 0xf7, 0x5c, 0xc1, 0x31, 0xbc, 0xdc, 0x6c, 0x85,
+ 0x68, 0x19, 0x27, 0x5c, 0x06, 0x98, 0x4b, 0x85,
+ 0xa7, 0x30, 0xa1, 0x0a, 0xb7, 0xc8, 0x5b, 0xe4,
+ 0xc6, 0x06, 0xef, 0xf5, 0x05, 0x86, 0x21, 0xc0,
+ 0x6f, 0xff, 0x98, 0x5c, 0x3f, 0xc2, 0xa2, 0x08,
+ 0x16, 0x81, 0x6e, 0xc3, 0xc5, 0x53, 0xae, 0x5a,
+ 0x93, 0xc9, 0xe5, 0x0c, 0xbe, 0x5c, 0xba, 0x00,
+ 0x60, 0x6c, 0x37, 0xc4, 0x08, 0x0d, 0x26, 0xe8,
+ 0x85, 0x81, 0x9a, 0x7a, 0xa1, 0x20, 0xd2, 0x90,
+ 0x1a, 0x68, 0xe6, 0x07, 0x48, 0x1b, 0x81, 0x8e,
+ 0x01, 0xc2, 0x65, 0x85, 0x08, 0x48, 0x2e, 0xda,
+ 0x16, 0x1f, 0xc9, 0xc4, 0x2b, 0x46, 0x65, 0x73,
+ 0xa6, 0x19, 0x98, 0xe5, 0xda, 0x06, 0x53, 0x34,
+ 0x22, 0x00, 0xcb, 0x04, 0x40, 0x1d, 0x4e, 0x0c,
+ 0x0c, 0x74, 0x8c, 0x23, 0x2f, 0xfc, 0xc6, 0xd3,
+ 0x50, 0x53, 0x1d, 0x52, 0x34, 0x65, 0x1a, 0xf7,
+ 0x6b, 0x97, 0xc7, 0xc4, 0xe7, 0x1b, 0x50, 0x39,
+ 0x4b, 0x14, 0x0c, 0x70, 0x2d, 0x2b, 0x24, 0x7e,
+ 0xc6, 0x81, 0xc6, 0xf2, 0x32, 0xcd, 0x2c, 0x4e,
+ 0x5f, 0xdb, 0x73, 0x4e, 0xac, 0xda, 0xc9, 0x1c,
+ 0x81, 0x90, 0xd8, 0x9c, 0x2c, 0xb4, 0x45, 0x0b,
+ 0x1f, 0x48, 0x14, 0xe7, 0xf5, 0xd4, 0x31, 0x1e,
+ 0x71, 0x48, 0x16, 0x3c, 0x44, 0x81, 0xcb, 0xeb,
+ 0x81, 0x70, 0x83, 0x10, 0x1b, 0x3e, 0x0a, 0x10,
+ 0xaf, 0xb5, 0x11, 0x92, 0x4e, 0xe3, 0x40, 0xfc,
+ 0x69, 0xd9, 0x24, 0xce, 0x32, 0x1f, 0xd8, 0x74,
+ 0xcb, 0xf5, 0xe3, 0x32, 0x81, 0x00, 0x1a, 0x25,
+ 0xde, 0x13, 0xaf, 0xd6, 0x4d, 0xdf, 0xf5, 0x8d,
+ 0x77, 0xfa, 0xe7, 0x8d, 0x3e, 0xb6, 0x33, 0x4f,
+ 0xd6, 0x69, 0xc7, 0xeb, 0x0d, 0x71, 0xf8, 0x47,
+ 0x98, 0xf1, 0x24, 0x10, 0xaf, 0x32, 0x15, 0xc3,
+ 0xe1, 0x10, 0x40, 0xf8, 0x4b, 0x08, 0x7d, 0x75,
+ 0xd7, 0x0a, 0x2c, 0x00, 0x2b, 0xf5, 0x84, 0x20,
+ 0x83, 0xb8, 0x4e, 0xa3, 0x28, 0x06, 0x18, 0x11,
+ 0x84, 0x2b, 0xc4, 0x43, 0x2d, 0xff, 0x20, 0x48,
+ 0x3c, 0x3c, 0xe6, 0x18, 0x7d, 0x08, 0xa7, 0xf9,
+ 0xa1, 0x70, 0xff, 0x18, 0x4f, 0x62, 0xc8, 0x16,
+ 0x1f, 0xe8, 0x09, 0x8f, 0xf7, 0xc4, 0x3d, 0x83,
+ 0x88, 0xc2, 0xbc, 0x2a, 0x52, 0xdf, 0xe0, 0x11,
+ 0x86, 0x19, 0x02, 0x69, 0xc6, 0x83, 0x58, 0xff,
+ 0x81, 0x67, 0x3f, 0xe0, 0x15, 0x8c, 0xd8, 0x72,
+ 0xfb, 0x20, 0xcc, 0x20, 0xc2, 0x46, 0x3f, 0xc8,
+ 0x2c, 0x83, 0xfa, 0x10, 0x3f, 0x37, 0x1d, 0x7e,
+ 0x7a, 0x12, 0x8c, 0x33, 0xb5, 0x9a, 0x0a, 0x20,
+ 0x67, 0xfa, 0x92, 0x99, 0xfe, 0x54, 0x53, 0x01,
+ 0xec, 0x07, 0x86, 0xd3, 0x02, 0x80, 0x16, 0xfc,
+ 0x6e, 0x45, 0x3d, 0xf9, 0x03, 0x24, 0x2f, 0xc2,
+ 0x65, 0x0b, 0xa1, 0x14, 0x46, 0x60, 0x04, 0x06,
+ 0x3f, 0xfe, 0x08, 0x83, 0xff, 0x02, 0x29, 0xfd,
+ 0xa4, 0x0b, 0x7e, 0xc0, 0x22, 0x8f, 0xed, 0x0d,
+ 0x87, 0xe2, 0xa3, 0x20, 0xfe, 0xc8, 0x8b, 0x60,
+ 0x90, 0x14, 0x08, 0x1b, 0x8c, 0xaf, 0xfb, 0xc6,
+ 0x61, 0x80, 0xf0, 0x49, 0xff, 0x74, 0xe7, 0x3f,
+ 0x4c, 0x10, 0x2a, 0xa2, 0xe4, 0x63, 0xfb, 0x8f,
+ 0xca, 0x3e, 0xe3, 0xf7, 0x2f, 0xb8, 0xf0, 0xb7,
+ 0xee, 0x3f, 0x70, 0xfb, 0x89, 0x5a, 0x72, 0xba,
+ 0x22, 0xde, 0xfd, 0x89, 0xef, 0x2a, 0x25, 0x32,
+ 0x1d, 0x6b, 0xf4, 0xcf, 0xa0, 0xad, 0x79, 0x94,
+ 0xfb, 0xba, 0xc9, 0x61, 0xef, 0x21, 0x1d, 0x3f,
+ 0xcc, 0x64, 0x08, 0xbe, 0x0d, 0xa7, 0x22, 0xc3,
+ 0x2a, 0xa7, 0x58, 0x4a, 0x3d, 0xfa, 0x52, 0x9f,
+ 0xe1, 0xa1, 0xcf, 0xe0, 0x27, 0x65, 0xe0, 0xa9,
+ 0xd8, 0xfb, 0x0e, 0x37, 0x3e, 0x87, 0x31, 0x43,
+ 0xab, 0x01, 0x3a, 0xf5, 0x71, 0x4c, 0xa1, 0xb2,
+ 0x33, 0x1a, 0xc4, 0x0d, 0xce, 0x40, 0x23, 0x67,
+ 0xdb, 0xa4, 0x58, 0xfa, 0x58, 0x22, 0x9f, 0x02,
+ 0x41, 0x03, 0xac, 0x06, 0x20, 0x87, 0x40, 0x1d,
+ 0xa4, 0x3e, 0x07, 0x5f, 0xaf, 0x09, 0xcf, 0xac,
+ 0x74, 0x67, 0xe7, 0xd9, 0x48, 0x7e, 0xc1, 0xc3,
+ 0x4d, 0xba, 0x89, 0x43, 0xeb, 0xef, 0x34, 0xfb,
+ 0x2d, 0xdd, 0xbf, 0x12, 0x32, 0x9e, 0xb4, 0x41,
+ 0xc7, 0xec, 0x7f, 0x0a, 0xfe, 0x64, 0x08, 0x7d,
+ 0x85, 0xc3, 0x2f, 0xb1, 0x50, 0xcb, 0xec, 0x5f,
+ 0x63, 0xe6, 0x53, 0x9d, 0xfd, 0x8b, 0xf0, 0xaf,
+ 0xe6, 0x40, 0x87, 0xc4, 0x9c, 0x62, 0xf6, 0x2c,
+ 0xcc, 0x7d, 0x8b, 0xf6, 0x3e, 0x16, 0xb9, 0x8f,
+ 0xc5, 0x1f, 0x0a, 0xfe, 0x64, 0x08, 0x7b, 0x0e,
+ 0xb7, 0x08, 0xc5, 0x19, 0x93, 0x0b, 0x09, 0x5b,
+ 0xc3, 0xcf, 0xd1, 0x70, 0xf3, 0xc7, 0x3d, 0x4f,
+ 0x01, 0xa7, 0x0d, 0xa1, 0x63, 0x9a, 0xc9, 0x08,
+ 0x30, 0xf9, 0xf6, 0x2c, 0x3e, 0x19, 0xcf, 0xf8,
+ 0xe3, 0x0a, 0xd3, 0x12, 0xd8, 0xe4, 0x9c, 0x36,
+ 0x3d, 0x27, 0xa9, 0x88, 0xeb, 0xb1, 0xa0, 0x32,
+ 0xc0, 0xe8, 0x25, 0xba, 0x51, 0x13, 0x7f, 0xfb,
+ 0x4c, 0x14, 0x33, 0xc9, 0xb0, 0x5b, 0xe2, 0x3a,
+ 0x66, 0x9b, 0x69, 0x81, 0x8b, 0xfd, 0x81, 0x3a,
+ 0x82, 0x48, 0xd8, 0xe4, 0x14, 0x22, 0x0b, 0x98,
+ 0x04, 0xea, 0xe5, 0xe6, 0x63, 0xff, 0x70, 0xca,
+ 0x60, 0x32, 0x07, 0x91, 0xec, 0x6d, 0x40, 0x5d,
+ 0xfe, 0x02, 0x33, 0xe0, 0x84, 0x2b, 0xb8, 0x4a,
+ 0x31, 0x6f, 0xf3, 0x0c, 0xc7, 0xfc, 0x41, 0x99,
+ 0x6f, 0xe0, 0xe5, 0x3f, 0xcc, 0x5b, 0x9f, 0xf3,
+ 0x0e, 0x7e, 0x65, 0x36, 0xe6, 0x98, 0x0f, 0x3f,
+ 0x9b, 0x5b, 0x36, 0x9d, 0x06, 0x41, 0xbc, 0xd3,
+ 0x31, 0xfd, 0xe8, 0x66, 0x03, 0xde, 0x20, 0x18,
+ 0xb7, 0xe7, 0x04, 0x20, 0xfb, 0x42, 0x9b, 0x3f,
+ 0xe0, 0x12, 0x9f, 0xb5, 0x15, 0x8b, 0xfc, 0x24,
+ 0x67, 0xfb, 0x4a, 0xd8, 0xbf, 0x98, 0x66, 0xcf,
+ 0xe3, 0x04, 0xcb, 0xed, 0x4f, 0x62, 0xfd, 0x69,
+ 0x1c, 0xfe, 0x6a, 0x76, 0x7f, 0xcc, 0x10, 0x83,
+ 0xe0, 0x6a, 0x70, 0xc8, 0xd0, 0x4a, 0x7f, 0x36,
+ 0x82, 0x0c, 0x83, 0x19, 0x77, 0xf3, 0x4a, 0x20,
+ 0xd7, 0xe8, 0x1c, 0x31, 0xe4, 0x16, 0xcf, 0xcc,
+ 0xad, 0xf6, 0xc2, 0xa0, 0x74, 0x98, 0x28, 0x1d,
+ 0x2b, 0xd4, 0x26, 0xdf, 0xe0, 0x9d, 0xcf, 0xf8,
+ 0x26, 0x0a, 0xf9, 0x90, 0x9d, 0x3f, 0xc6, 0x53,
+ 0xef, 0xa8, 0xa4, 0x2b, 0x24, 0x06, 0x62, 0xfb,
+ 0xb3, 0x4a, 0x60, 0x46, 0x13, 0x09, 0x1c, 0x01,
+ 0xbc, 0xed, 0x2a, 0xf0, 0xb6, 0xff, 0x31, 0x21,
+ 0x58, 0xfb, 0x2b, 0x6f, 0xee, 0x0c, 0xc7, 0x04,
+ 0x81, 0x9d, 0xc9, 0x08, 0xa5, 0xbf, 0x60, 0x21,
+ 0x96, 0x98, 0xdc, 0xdb, 0xf8, 0x91, 0x33, 0xfe,
+ 0xf4, 0xa7, 0xf1, 0x60, 0x13, 0x4d, 0x8a, 0xc0,
+ 0xcd, 0x23, 0x34, 0xb1, 0xf6, 0x74, 0xa4, 0x12,
+ 0x2a, 0x49, 0x17, 0xf1, 0x12, 0xc7, 0xf5, 0xc2,
+ 0x05, 0x55, 0xdc, 0x61, 0x52, 0xae, 0x31, 0x6f,
+ 0xbc, 0x48, 0xe7, 0xa7, 0x61, 0x9d, 0x67, 0xbd,
+ 0x0e, 0x70, 0xbe, 0x11, 0x80, 0xf2, 0x1a, 0x60,
+ 0x62, 0x8e, 0xb0, 0xdb, 0xa3, 0x52, 0x06, 0x49,
+ 0x03, 0x01, 0xbe, 0x15, 0x00, 0x74, 0x34, 0xfc,
+ 0xc0, 0x04, 0x10, 0xa1, 0x1b, 0x34, 0x6f, 0x40,
+ 0x41, 0xfb, 0xe3, 0x11, 0x7f, 0x40, 0xa7, 0xbf,
+ 0x6b, 0x13, 0xa6, 0x6d, 0x0c, 0xcd, 0xf3, 0x13,
+ 0x32, 0x9e, 0x21, 0xf0, 0x16, 0x5f, 0xc4, 0x0d,
+ 0xb7, 0xd8, 0x42, 0x6d, 0xe9, 0xf1, 0x08, 0x20,
+ 0xb2, 0x36, 0xff, 0x6f, 0x88, 0xbf, 0x3f, 0xe0,
+ 0x2b, 0x99, 0x80, 0x58, 0xec, 0xa4, 0x22, 0x08,
+ 0x62, 0x85, 0xce, 0x76, 0xc2, 0x74, 0xcb, 0x5a,
+ 0x98, 0xbb, 0x5e, 0x43, 0x0c, 0x0a, 0x01, 0xa6,
+ 0xa6, 0x60, 0x73, 0x81, 0x00, 0x98, 0x6a, 0x5e,
+ 0x06, 0xf8, 0x2f, 0x01, 0xd2, 0x26, 0x47, 0x6f,
+ 0x86, 0xd8, 0x08, 0x23, 0xf0, 0x02, 0x08, 0x40,
+ 0x01, 0xb6, 0x24, 0x60, 0x79, 0xfb, 0x71, 0x5d,
+ 0x32, 0xca, 0xa6, 0x2e, 0x5b, 0x85, 0xcf, 0xfd,
+ 0x52, 0x6c, 0xe4, 0x70, 0x59, 0x7e, 0xb8, 0x87,
+ 0x3f, 0xe3, 0x2d, 0x9f, 0xa6, 0x48, 0x3e, 0xf9,
+ 0x0a, 0xd9, 0xfb, 0x02, 0x57, 0x38, 0xb3, 0x89,
+ 0xca, 0x8d, 0xa0, 0x69, 0x98, 0x18, 0x58, 0x7e,
+ 0xeb, 0xf3, 0xee, 0xfc, 0x1d, 0x97, 0xce, 0xe8,
+ 0x65, 0x80, 0x48, 0x1e, 0xe8, 0xb0, 0x16, 0x1b,
+ 0x38, 0x89, 0xd7, 0x0c, 0xeb, 0x75, 0xf9, 0xea,
+ 0x5a, 0x7c, 0xa2, 0x40, 0xaf, 0xf6, 0x29, 0x97,
+ 0xb8, 0x06, 0x63, 0xfe, 0x11, 0x1d, 0x3e, 0xc4,
+ 0xe7, 0x58, 0x31, 0x81, 0xbf, 0xaf, 0xa0, 0x0a,
+ 0xc5, 0x41, 0x9e, 0xf7, 0xae, 0xa2, 0xdf, 0xc7,
+ 0x95, 0xf7, 0xd2, 0xaf, 0x0a, 0xbf, 0x7a, 0xd8,
+ 0xfa, 0xbc, 0x76, 0x3f, 0x48, 0x00, 0x83, 0xea,
+ 0xd5, 0x74, 0xfe, 0x73, 0xc8, 0x3e, 0x6a, 0x02,
+ 0xb9, 0x48, 0x01, 0xd6, 0x50, 0x00, 0x3e, 0x9a,
+ 0xb0, 0x1d, 0x3e, 0x74, 0xf6, 0x3f, 0xa7, 0xd5,
+ 0xd3, 0xf7, 0x10, 0x2b, 0xf9, 0xd1, 0x9c, 0xa0,
+ 0x5c, 0x07, 0x4f, 0x82, 0xc0, 0xee, 0x06, 0xe1,
+ 0x74, 0x3c, 0x9c, 0x20, 0x0c, 0x07, 0xbb, 0x96,
+ 0x50, 0xff, 0x68, 0x24, 0x69, 0xde, 0xb0, 0x0b,
+ 0xa5, 0x04, 0x02, 0x8d, 0x9a, 0x0c, 0xa4, 0x41,
+ 0x27, 0x80, 0x32, 0xf5, 0xa8, 0x24, 0x1c, 0xf2,
+ 0x23, 0xa5, 0xc0, 0x4c, 0x5d, 0xbb, 0x01, 0x16,
+ 0xdb, 0xe1, 0x01, 0x5f, 0xe6, 0x43, 0x1e, 0xa5,
+ 0xc6, 0x5b, 0x6d, 0xc2, 0x05, 0x7e, 0x40, 0x41,
+ 0x55, 0x25, 0x1b, 0x7e, 0xb9, 0x00, 0xc3, 0x11,
+ 0xe0, 0x10, 0x46, 0xb8, 0x2e, 0x79, 0xe4, 0x21,
+ 0x95, 0xaa, 0x0e, 0xdd, 0x5c, 0x52, 0xb3, 0xd2,
+ 0xe4, 0x26, 0x51, 0x76, 0x10, 0x57, 0xfc, 0x96,
+ 0x41, 0xfc, 0x42, 0x85, 0x41, 0x44, 0x4d, 0x10,
+ 0x08, 0x03, 0x46, 0x7c, 0x00, 0xc9, 0xfb, 0x71,
+ 0x9d, 0x45, 0x90, 0xcd, 0x1f, 0xeb, 0x31, 0x4f,
+ 0xee, 0x0c, 0x41, 0xfd, 0x81, 0x05, 0x6f, 0x4c,
+ 0xc4, 0x1b, 0x8f, 0x59, 0x05, 0x46, 0x06, 0x5b,
+ 0xc8, 0x65, 0x37, 0xc1, 0x34, 0xec, 0xdb, 0xea,
+ 0x11, 0xdd, 0x99, 0xd6, 0xe7, 0x93, 0x42, 0x39,
+ 0xc7, 0x5d, 0x0d, 0x1f, 0x7b, 0x0b, 0x9e, 0x55,
+ 0xcc, 0x65, 0x26, 0xc1, 0x10, 0x4e, 0xe0, 0x8d,
+ 0x1f, 0x62, 0x28, 0x54, 0xfd, 0x08, 0xd1, 0xf5,
+ 0x33, 0x3d, 0xd6, 0xea, 0x8e, 0x74, 0x90, 0x03,
+ 0x2d, 0x2d, 0x02, 0x5b, 0x05, 0xf0, 0x34, 0x7f,
+ 0x1c, 0xce, 0x9e, 0x9d, 0x3b, 0x47, 0xc5, 0x8c,
+ 0x5b, 0x5c, 0xd2, 0x05, 0x67, 0x30, 0xcd, 0x1e,
+ 0xfd, 0xf9, 0xf7, 0xf0, 0x9a, 0xcf, 0x36, 0x04,
+ 0x10, 0x64, 0xc4, 0x25, 0xbc, 0xbf, 0x79, 0x4f,
+ 0xa5, 0x8a, 0x65, 0xa7, 0x91, 0x96, 0xfd, 0x95,
+ 0x6e, 0x73, 0x23, 0x09, 0x6d, 0x52, 0x8a, 0xd1,
+ 0xf2, 0x03, 0x1d, 0xf4, 0x6c, 0xa5, 0x1f, 0xb2,
+ 0xf9, 0x07, 0xc5, 0xd8, 0xc7, 0xb7, 0x60, 0x05,
+ 0x7e, 0xca, 0x2c, 0xb7, 0x70, 0xfb, 0x25, 0xdc,
+ 0x14, 0xa0, 0x4c, 0x20, 0x95, 0x08, 0xc4, 0xf2,
+ 0x91, 0x36, 0xed, 0x80, 0x53, 0xbb, 0x6c, 0x94,
+ 0xee, 0x92, 0x05, 0x72, 0x49, 0x3a, 0xfe, 0x60,
+ 0x22, 0xec, 0x49, 0x8b, 0x60, 0x7a, 0x16, 0x58,
+ 0x06, 0x01, 0xa7, 0x4d, 0x23, 0x30, 0xc4, 0x08,
+ 0x16, 0xee, 0x46, 0x23, 0xa1, 0x01, 0x1e, 0x06,
+ 0x40, 0x50, 0x82, 0xb0, 0x18, 0xc8, 0x32, 0x02,
+ 0x0b, 0x2c, 0x0d, 0x02, 0x51, 0xa4, 0x00, 0x30,
+ 0xeb, 0xa4, 0x05, 0xb2, 0x12, 0x1b, 0x77, 0xfd,
+ 0x84, 0xeb, 0xd9, 0x10, 0x36, 0xf6, 0x50, 0x0e,
+ 0xb7, 0x96, 0x01, 0x04, 0x7e, 0xca, 0xcb, 0x02,
+ 0x21, 0x99, 0x88, 0x0b, 0x91, 0xed, 0x03, 0x91,
+ 0x9c, 0xeb, 0xab, 0xd0, 0x37, 0x1d, 0x08, 0x77,
+ 0x64, 0x19, 0x87, 0xfb, 0x82, 0xcd, 0x07, 0x30,
+ 0xba, 0x10, 0x7f, 0xd2, 0x54, 0x2b, 0x5b, 0x81,
+ 0x98, 0xd3, 0x14, 0xc0, 0x32, 0x42, 0x94, 0x2b,
+ 0x90, 0x1a, 0x03, 0x9d, 0xbc, 0x86, 0x83, 0xfe,
+ 0x47, 0x14, 0x46, 0x40, 0x6e, 0x5a, 0x62, 0x01,
+ 0x6f, 0xe9, 0x0a, 0x53, 0xfb, 0x91, 0x3a, 0xc9,
+ 0x80, 0x0e, 0x96, 0x7b, 0x0a, 0x0f, 0xda, 0xc8,
+ 0x14, 0x5b, 0xcf, 0xa0, 0x1d, 0x4d, 0x96, 0x6a,
+ 0x03, 0x1e, 0x8e, 0x42, 0x5b, 0xff, 0xb1, 0x3a,
+ 0x70, 0xf8, 0x25, 0xbf, 0xdb, 0x31, 0x07, 0xf9,
+ 0x10, 0xe5, 0x00, 0xc0, 0x3a, 0x9c, 0xad, 0xb2,
+ 0x07, 0x9f, 0xf1, 0x05, 0xa6, 0xda, 0x40, 0x65,
+ 0x82, 0x08, 0x1c, 0xa2, 0x48, 0x07, 0x2b, 0x35,
+ 0x81, 0xa6, 0x04, 0x20, 0x72, 0xa0, 0x80, 0x08,
+ 0x3e, 0xc2, 0x26, 0x13, 0x3c, 0x14, 0x80, 0xbb,
+ 0xfb, 0x24, 0x10, 0x40, 0xa8, 0x49, 0x90, 0x13,
+ 0x0a, 0x61, 0xa4, 0xc5, 0xfd, 0xd0, 0x39, 0x5d,
+ 0x20, 0x4d, 0xdf, 0x01, 0x71, 0x6f, 0x29, 0x02,
+ 0xdb, 0xef, 0xe2, 0x14, 0xfc, 0xd4, 0x6c, 0x3f,
+ 0x09, 0xfb, 0x37, 0xc2, 0x46, 0x63, 0xf0, 0x9c,
+ 0xad, 0xd6, 0xa4, 0x49, 0x9f, 0x87, 0x42, 0x0d,
+ 0x66, 0xc0, 0xd7, 0x80, 0x30, 0x37, 0x40, 0x78,
+ 0x06, 0x63, 0x21, 0x71, 0x92, 0x0d, 0xa1, 0x47,
+ 0xf3, 0x53, 0x1b, 0x3e, 0x7a, 0x87, 0x5f, 0x72,
+ 0xb1, 0xb7, 0xdc, 0xff, 0x61, 0xf7, 0x3f, 0xd7,
+ 0x3d, 0xcf, 0x54, 0x6b, 0xce, 0x05, 0x33, 0xdc,
+ 0xe7, 0x68, 0xef, 0xca, 0x1c, 0xce, 0xa6, 0x38,
+ 0x04, 0x81, 0xcf, 0xbf, 0x22, 0x31, 0xef, 0xcf,
+ 0xdd, 0x3b, 0xf2, 0x73, 0x0f, 0x78, 0x79, 0x1b,
+ 0xf2, 0x08, 0x22, 0xf7, 0x8f, 0xdc, 0xbd, 0xe3,
+ 0xf6, 0xce, 0xec, 0x7d, 0xc3, 0xbb, 0x1f, 0x6c,
+ 0xee, 0xc2, 0x51, 0x0c, 0xb4, 0x8e, 0x03, 0x39,
+ 0x0a, 0x7a, 0xa0, 0x61, 0x35, 0xc0, 0x28, 0x25,
+ 0xb6, 0x4a, 0x22, 0xe7, 0x3e, 0xfe, 0xd3, 0xf0,
+ 0x2f, 0xb2, 0x77, 0xc8, 0x88, 0x9f, 0xa1, 0x39,
+ 0x17, 0x7d, 0x3e, 0xe5, 0xdf, 0x4f, 0xb6, 0x73,
+ 0x6f, 0xee, 0x15, 0xc0, 0x03, 0xb1, 0xbc, 0xd3,
+ 0x65, 0x50, 0x37, 0xf3, 0x7b, 0xe4, 0x04, 0xfb,
+ 0x68, 0x81, 0xc2, 0xd9, 0xc0, 0x44, 0xf8, 0x00,
+ 0x94, 0xe6, 0x56, 0x42, 0x88, 0x06, 0x11, 0xd7,
+ 0x58, 0xe5, 0x20, 0xdf, 0x9f, 0xd0, 0xb9, 0xd5,
+ 0xf6, 0xce, 0x75, 0x15, 0x3e, 0xcc, 0x80, 0x70,
+ 0xb3, 0x08, 0x11, 0x3d, 0x26, 0x25, 0x3d, 0xe6,
+ 0x10, 0x8b, 0x9c, 0x9f, 0x72, 0xe7, 0x27, 0xdb,
+ 0x37, 0x97, 0xf7, 0x0a, 0x58, 0x01, 0xd8, 0xde,
+ 0x69, 0xaa, 0x28, 0x1b, 0xf7, 0x9d, 0xf2, 0x0d,
+ 0x66, 0x05, 0x52, 0x43, 0xc0, 0x6b, 0xd8, 0x40,
+ 0xc8, 0x3b, 0xe8, 0x37, 0x49, 0x07, 0x81, 0xaf,
+ 0x5d, 0x22, 0x30, 0xd7, 0x4f, 0xdd, 0x39, 0xe1,
+ 0xf6, 0x5d, 0xf0, 0x19, 0x1e, 0x02, 0xe0, 0x54,
+ 0x8d, 0xb8, 0x1a, 0xf5, 0x42, 0x32, 0x2d, 0xf0,
+ 0x7d, 0xcb, 0x7c, 0x1f, 0x6c, 0xd6, 0x3f, 0xdc,
+ 0x35, 0x8f, 0xf6, 0xcd, 0x63, 0x9d, 0x4e, 0x1d,
+ 0x00, 0x75, 0x84, 0x58, 0x1c, 0xb6, 0x9e, 0x42,
+ 0x2d, 0x5d, 0x2d, 0x8e, 0x30, 0x06, 0x75, 0x83,
+ 0x50, 0x1c, 0xb6, 0x5c, 0x40, 0xa8, 0x0c, 0x01,
+ 0x37, 0x34, 0x01, 0x61, 0x81, 0x28, 0x10, 0x8d,
+ 0xe7, 0x88, 0x11, 0x85, 0x9b, 0x4e, 0xa2, 0x20,
+ 0x84, 0xb0, 0x1d, 0x22, 0x7a, 0x02, 0xda, 0xb9,
+ 0x11, 0xa4, 0xe9, 0x13, 0x20, 0x16, 0xd4, 0xb8,
+ 0x0c, 0x57, 0x27, 0x03, 0xcd, 0x48, 0x88, 0xc5,
+ 0x71, 0xd0, 0x3c, 0xe6, 0x04, 0x4e, 0xf0, 0x58,
+ 0x01, 0x04, 0x0e, 0x42, 0xc5, 0x44, 0xc0, 0x3a,
+ 0x68, 0x48, 0x25, 0x20, 0xa1, 0xb6, 0x61, 0x7e,
+ 0xe9, 0xa9, 0x84, 0x99, 0x08, 0x07, 0x19, 0xfb,
+ 0x63, 0x1e, 0x5d, 0xaa, 0xa7, 0x01, 0x80, 0x26,
+ 0xe3, 0xf8, 0x2c, 0x30, 0xd6, 0x02, 0x11, 0xbc,
+ 0xf1, 0xa7, 0x00, 0xba, 0xc4, 0x04, 0x0e, 0x5a,
+ 0x72, 0xfb, 0xae, 0x9c, 0xbe, 0xcd, 0x95, 0x9f,
+ 0xb3, 0xe5, 0x67, 0xe4, 0x10, 0x72, 0x01, 0x81,
+ 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01,
+ 0x84, 0x75, 0x80, 0xc7, 0x02, 0x23, 0x26, 0x90,
+ 0xb0, 0x08, 0x04, 0xb8, 0xe2, 0x81, 0xe0, 0x60,
+ 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01, 0x86, 0x64,
+ 0x00, 0xc7, 0x00, 0x83, 0x26, 0x90, 0xaf, 0xd4,
+ 0x04, 0xb2, 0x19, 0x04, 0x9c, 0x43, 0x22, 0x93,
+ 0x23, 0x4a, 0x07, 0x81, 0x80, 0xc0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x18, 0x79, 0x03, 0x1d, 0xee,
+ 0x02, 0xe8, 0x61, 0x80, 0x70, 0x53, 0x48, 0x45,
+ 0xf2, 0x09, 0x0a, 0xf8, 0x80, 0x54, 0x29, 0x11,
+ 0x4a, 0x85, 0x22, 0xc9, 0x24, 0x8e, 0x4e, 0xbd,
+ 0xc8, 0x11, 0x62, 0xfa, 0x07, 0x81, 0x80, 0xc0,
+ 0x60, 0x30, 0x18, 0x0c, 0x06, 0x18, 0x25, 0x03,
+ 0x1d, 0xe4, 0x02, 0xe8, 0x61, 0x80, 0x40, 0x53,
+ 0x48, 0x45, 0xf2, 0xc9, 0x14, 0xa6, 0x4e, 0x27,
+ 0x90, 0xc8, 0x24, 0xe2, 0x19, 0x14, 0x99, 0x15,
+ 0xa0, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x60, 0x30, 0x1a, 0x54, 0xd0, 0x2d, 0xd1, 0xbc,
+ 0x03, 0x0c, 0x01, 0x42, 0x9a, 0x42, 0x2f, 0x96,
+ 0x48, 0xa5, 0x32, 0x71, 0x3e, 0x27, 0xa0, 0x78,
+ 0x18, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0, 0x60,
+ 0x35, 0xa8, 0xb8, 0x5b, 0xa3, 0x3e, 0x06, 0x18,
+ 0x0d, 0x05, 0x34, 0x84, 0x5f, 0x29, 0x11, 0x4a,
+ 0x85, 0x22, 0xc9, 0x0c, 0x82, 0x4e, 0x21, 0x91,
+ 0x49, 0x91, 0x1a, 0x03, 0xc0, 0xc0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x03, 0x18, 0x88, 0x81, 0x8e,
+ 0xe5, 0xa1, 0x74, 0x30, 0xd0, 0x1c, 0x29, 0xa4,
+ 0x22, 0xfd, 0xcc, 0x80, 0x9e, 0x4e, 0x24, 0x10,
+ 0x49, 0xc4, 0x48, 0x7d, 0x01, 0xe0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x03, 0x01, 0x94, 0x3c, 0x40,
+ 0xc7, 0x70, 0xd0, 0xba, 0x18, 0x67, 0xce, 0x14,
+ 0xd2, 0x11, 0x7e, 0xe2, 0x40, 0x4f, 0x27, 0x14,
+ 0x4a, 0xa4, 0x52, 0x99, 0x50, 0x93, 0x71, 0xe0,
+ 0x05, 0x0c, 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x60,
+ 0x30, 0x18, 0x0c, 0xe1, 0x9a, 0x06, 0x3b, 0x74,
+ 0x85, 0xd0, 0xc3, 0x3c, 0x30, 0xa6, 0x90, 0x8b,
+ 0xf6, 0xee, 0x02, 0x79, 0x38, 0x8a, 0x58, 0xb7,
+ 0x48, 0x10, 0x49, 0xb6, 0xea, 0x02, 0x4d, 0xbd,
+ 0xc0, 0x14, 0x30, 0x3c, 0x0c, 0x06, 0x03, 0x01,
+ 0x80, 0xc0, 0x60, 0x34, 0x85, 0x30, 0x18, 0xed,
+ 0x84, 0x17, 0x43, 0x0c, 0xe7, 0x02, 0x9a, 0x42,
+ 0x2f, 0xdb, 0x1c, 0x09, 0xe4, 0xe2, 0x09, 0x4c,
+ 0xa8, 0x45, 0x29, 0x12, 0x4a, 0x64, 0xb8, 0x45,
+ 0x81, 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03,
+ 0x01, 0xc4, 0x20, 0x80, 0xc7, 0x69, 0xe0, 0xba,
+ 0x18, 0x66, 0xf0, 0x14, 0xd2, 0x11, 0x7c, 0xaa,
+ 0x53, 0x22, 0x94, 0xad, 0x3e, 0x04, 0xf2, 0x74,
+ 0x1a, 0xc0, 0xf0, 0x30, 0x18, 0x0c, 0x06, 0x03,
+ 0x01, 0x80, 0xc2, 0x0c, 0x40, 0x63, 0xb3, 0xf0,
+ 0x5d, 0x0c, 0x33, 0x58, 0x0a, 0x69, 0x08, 0xbe,
+ 0x44, 0x22, 0x91, 0x88, 0x45, 0x52, 0xa1, 0x52,
+ 0xd2, 0x40, 0x31, 0x82, 0x48, 0x1e, 0x06, 0x03,
+ 0x01, 0x80, 0xc0, 0x60, 0x31, 0x18, 0x41, 0x00,
+ 0x0c, 0x76, 0x5c, 0x0b, 0xa1, 0x86, 0x66, 0xc1,
+ 0x4d, 0x21, 0x17, 0xc8, 0x84, 0x52, 0x31, 0x08,
+ 0xaa, 0x54, 0x2a, 0x59, 0xc0, 0x06, 0x50, 0x27,
+ 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0c, 0x06,
+ 0x43, 0x08, 0x0f, 0x01, 0x8e, 0xc7, 0x41, 0x74,
+ 0x30, 0xcc, 0x50, 0x29, 0xa4, 0x22, 0xf9, 0x10,
+ 0x8a, 0x46, 0x21, 0x15, 0x4a, 0x85, 0x4b, 0x27,
+ 0x00, 0xce, 0x00, 0xa0, 0x78, 0x18, 0x0c, 0x06,
+ 0x03, 0x01, 0x80, 0xcc, 0x61, 0x01, 0x30, 0x31,
+ 0xd8, 0x60, 0x2e, 0x86, 0x19, 0x79, 0x05, 0x34,
+ 0x84, 0x5f, 0x22, 0x11, 0x48, 0xc4, 0x22, 0xa9,
+ 0x50, 0xa9, 0x62, 0xc0, 0x1a, 0x5a, 0x98, 0x0f,
+ 0x03, 0x01, 0x80, 0xc0, 0x60, 0x30, 0x18, 0x0c,
+ 0x2d, 0x3a, 0x06, 0x3a, 0xfb, 0x05, 0xd0, 0xc3,
+ 0x2d, 0x00, 0xa6, 0x90, 0x8b, 0xe4, 0x12, 0x85,
+ 0x7f, 0x40, 0x9a, 0x4f, 0x22, 0x10, 0x49, 0x96,
+ 0x85, 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0c,
+ 0x46, 0x03, 0x0b, 0x3e, 0x01, 0x8e, 0xba, 0xa1,
+ 0x74, 0x30, 0xca, 0xbc, 0x29, 0xa4, 0x22, 0xf9,
+ 0x4c, 0xb2, 0x53, 0x2a, 0x11, 0x49, 0xa4, 0xd2,
+ 0x79, 0x10, 0x82, 0x4c, 0xb3, 0x10, 0x1e, 0x06,
+ 0x03, 0x01, 0x80, 0xc0, 0x64, 0x30, 0x18, 0x59,
+ 0x64, 0x0c, 0x75, 0xb2, 0x0b, 0xa1, 0x86, 0x51,
+ 0x81, 0x4d, 0x21, 0x17, 0xca, 0x84, 0x12, 0x99,
+ 0x2c, 0x9a, 0x4f, 0x22, 0x10, 0x49, 0x96, 0x41,
+ 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0d, 0x06,
+ 0x03, 0x0b, 0x1c, 0x01, 0x8e, 0xb2, 0x21, 0x74,
+ 0x30, 0xc9, 0xac, 0x29, 0xa4, 0x22, 0xf9, 0x20,
+ 0x8a, 0x4c, 0x28, 0x58, 0x94, 0x0f, 0x03, 0x01,
+ 0x80, 0xc0, 0x60, 0x38, 0x18, 0x0c, 0x2c, 0x38,
+ 0x06, 0x3a, 0xba, 0x85, 0xd0, 0xc3, 0x24, 0xf0,
+ 0xa6, 0x90, 0x8b, 0xe4, 0xe2, 0x7d, 0x60, 0x00,
+ 0x86, 0x55, 0x29, 0xd8, 0x18, 0x0f, 0x03, 0x01,
+ 0x80, 0xc0, 0x62, 0x30, 0x18, 0x0c, 0x2b, 0xfa,
+ 0x06, 0x3a, 0xab, 0x05, 0xd0, 0xc3, 0x23, 0x00,
+ 0xa6, 0x90, 0x8b, 0xe5, 0x32, 0x2d, 0x58, 0x04,
+ 0x8a, 0x47, 0xab, 0x40, 0x15, 0x49, 0xc4, 0x4a,
+ 0xf0, 0x81, 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x86,
+ 0x03, 0x01, 0x85, 0x76, 0x00, 0xc7, 0x53, 0x10,
+ 0xba, 0x18, 0x64, 0x16, 0x14, 0xd2, 0x11, 0x7c,
+ 0x88, 0x45, 0x23, 0x10, 0x4a, 0xa4, 0xc2, 0xa1,
+ 0x7c, 0x88, 0x45, 0x29, 0x92, 0xca, 0x84, 0xf2,
+ 0x85, 0x4c, 0xc0, 0x9c, 0x4c, 0x2c, 0xd6, 0xd4,
+ 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x68, 0x30, 0x18,
+ 0x0c, 0x2b, 0x58, 0x06, 0x3a, 0x82, 0x85, 0xd0,
+ 0xc3, 0x1d, 0xf0, 0xa6, 0x90, 0x8b, 0xe5, 0x42,
+ 0x79, 0x40, 0x9b, 0x51, 0x30, 0x2a, 0x56, 0x58,
+ 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x70, 0x30, 0x18,
+ 0x0c, 0x2b, 0x1a, 0x06, 0x3a, 0x73, 0x05, 0xd0,
+ 0xc3, 0x1c, 0x00, 0xa6, 0x90, 0x8b, 0xe5, 0x22,
+ 0x49, 0x1c, 0x90, 0x54, 0xab, 0xc8, 0x1e, 0x06,
+ 0x03, 0x01, 0x88, 0xc0, 0x60, 0x30, 0x18, 0x55,
+ 0xc0, 0x0c, 0x74, 0xc9, 0x0b, 0xa1, 0x86, 0x34,
+ 0x61, 0x4d, 0x21, 0x17, 0xca, 0x45, 0x42, 0x61,
+ 0x48, 0x8a, 0x41, 0x22, 0x53, 0xb8, 0x08, 0xe0,
+ 0xa2, 0x69, 0x08, 0xbf, 0x4c, 0x00, 0x27, 0x93,
+ 0x88, 0xa5, 0x8a, 0x5d, 0x81, 0x04, 0x9b, 0x4b,
+ 0xc0, 0x24, 0xd3, 0x24, 0x04, 0x10, 0xe8, 0x03,
+ 0x74, 0x9b, 0x80, 0xc3, 0x17, 0x90, 0xa6, 0x90,
+ 0x8b, 0xf4, 0xa4, 0x02, 0x79, 0x38, 0xae, 0x41,
+ 0x29, 0x13, 0xa9, 0x86, 0x04, 0x70, 0x51, 0x34,
+ 0x84, 0x5f, 0xa4, 0xa8, 0x13, 0xc9, 0xc4, 0x82,
+ 0x09, 0x38, 0x89, 0x24, 0x20, 0xb7, 0x49, 0x28,
+ 0x0c, 0x31, 0x55, 0x0a, 0x69, 0x08, 0xbf, 0x48,
+ 0x00, 0x27, 0x93, 0x88, 0xa5, 0x2a, 0x47, 0x81,
+ 0x48, 0x14, 0x4d, 0x21, 0x17, 0xe8, 0xe6, 0x04,
+ 0xf2, 0x71, 0x04, 0xa6, 0x54, 0x22, 0x94, 0x89,
+ 0x25, 0x32, 0x5c, 0x87, 0x02, 0xdd, 0x22, 0x40,
+ 0x30, 0xc4, 0xbc, 0x29, 0xa4, 0x22, 0xfd, 0x16,
+ 0x80, 0x9e, 0x4e, 0xa3, 0xe8, 0x11, 0xa8, 0xb8,
+ 0x14, 0x12, 0xa1, 0x26, 0x8c, 0x60, 0x0a, 0x26,
+ 0x90, 0x8b, 0xf4, 0x47, 0x02, 0x79, 0x38, 0x90,
+ 0x41, 0x27, 0x11, 0x23, 0xe8, 0x16, 0xe8, 0xfe,
+ 0x01, 0x86, 0x20, 0xe1, 0x4d, 0x21, 0x17, 0xe8,
+ 0x64, 0x04, 0xf2, 0x71, 0x4c, 0xa8, 0x4f, 0x28,
+ 0x52, 0xf4, 0x0f, 0x03, 0x01, 0x80, 0xc8, 0x60,
+ 0x30, 0x18, 0x0c, 0x29, 0x68, 0x06, 0x3a, 0x06,
+ 0x85, 0xd0, 0xc3, 0x0e, 0x70, 0xa6, 0x90, 0x8b,
+ 0xe5, 0x32, 0x29, 0x4a, 0x84, 0x40, 0x43, 0x22,
+ 0x97, 0xc9, 0xc4, 0xf2, 0xa1, 0x26, 0x80, 0xa1,
+ 0x41, 0x2a, 0x12, 0x68, 0x2c, 0x00, 0xa1, 0x81,
+ 0xe0, 0x60, 0x30, 0x18, 0x0d, 0x06, 0x03, 0x01,
+ 0x85, 0x22, 0x00, 0xc7, 0x3e, 0x10, 0xba, 0x18,
+ 0x61, 0x76, 0x14, 0xd2, 0x11, 0x7c, 0xa6, 0x45,
+ 0x29, 0x4f, 0xd8, 0x08, 0x64, 0x52, 0xf9, 0x38,
+ 0x9e, 0x54, 0x24, 0xcf, 0x64, 0x28, 0x25, 0x42,
+ 0x4c, 0xfa, 0x80, 0x14, 0x30, 0x3c, 0x0c, 0x06,
+ 0x03, 0x01, 0xa0, 0xc0, 0x60, 0x30, 0xa2, 0xe0,
+ 0x18, 0xe7, 0x6a, 0x17, 0x43, 0x0c, 0x23, 0xc2,
+ 0x9a, 0x42, 0x2f, 0x94, 0xc8, 0xa5, 0x29, 0xe5,
+ 0x01, 0x0c, 0x8a, 0x5f, 0x27, 0x13, 0xca, 0x84,
+ 0x99, 0xd6, 0x85, 0x04, 0xa8, 0x49, 0x9d, 0xf0,
+ 0x17, 0xe7, 0x7e, 0x03, 0x32, 0xc5, 0x0d, 0x00,
+ 0xf0, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01, 0x80,
+ 0xc0, 0x8d, 0x14, 0xb0, 0xb7, 0x45, 0x4c, 0x0c,
+ 0x30, 0x5e, 0x0a, 0x69, 0x08, 0xbe, 0x54, 0x2c,
+ 0x94, 0x08, 0xa4, 0xd2, 0x09, 0x4c, 0x97, 0x41,
+ 0x40, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x60, 0x46, 0xa0, 0x58, 0x18, 0xe6, 0xc8, 0x17,
+ 0x43, 0x0c, 0x0f, 0x82, 0x9a, 0x42, 0x2f, 0xcd,
+ 0xa4, 0x09, 0xf3, 0x7d, 0x02, 0x09, 0x4c, 0x97,
+ 0x3f, 0x40, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80,
+ 0xc0, 0x8c, 0x30, 0x9f, 0x58, 0x18, 0xe6, 0x88,
+ 0x17, 0x43, 0x0c, 0x07, 0x82, 0x9a, 0x42, 0x2f,
+ 0x91, 0x08, 0xa4, 0x62, 0x69, 0x04, 0xa6, 0x4b,
+ 0x9e, 0xa8, 0x1e, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x66, 0x30, 0x18, 0x4f, 0x30, 0x0c, 0x73, 0x25,
+ 0x0b, 0xa1, 0x86, 0x08, 0xe1, 0x4d, 0x21, 0x17,
+ 0xc9, 0xa4, 0xf2, 0x21, 0x14, 0x9a, 0x41, 0x29,
+ 0x92, 0xe7, 0x6a, 0x07, 0x81, 0x80, 0xc0, 0x60,
+ 0x30, 0x21, 0x8c, 0x06, 0x13, 0xac, 0x03, 0x1c,
+ 0xc1, 0x42, 0xe8, 0x61, 0x81, 0x38, 0x53, 0x48,
+ 0x45, 0xf2, 0x69, 0x24, 0xa6, 0x43, 0x26, 0x90,
+ 0x4a, 0x64, 0xba, 0x53, 0x05, 0x8e, 0x5d, 0xc1,
+ 0x74, 0x30, 0xc0, 0x40, 0x29, 0x24, 0x42, 0x79,
+ 0x2e, 0x73, 0xe1, 0x63, 0x96, 0xf0, 0x5d, 0x0c,
+ 0x30, 0x00, 0x0a, 0x49, 0x10, 0x86, 0x41, 0x27,
+ 0x10, 0xc8, 0xa4, 0xc9, 0xaf, 0x85, 0x8e, 0x59,
+ 0x41, 0x74, 0x30, 0xc1, 0xdc, 0x29, 0x24, 0x42,
+ 0x09, 0x0a, 0x5a, 0xe0, 0x54, 0x05, 0x0d, 0x20,
+ 0xfc, 0x16, 0xe8, 0x43, 0x01, 0x86, 0x0c, 0x81,
+ 0x49, 0x22, 0x14, 0x88, 0xa5, 0x42, 0x91, 0x64,
+ 0x14, 0x35, 0x83, 0x58, 0x5b, 0xa0, 0xe6, 0x06,
+ 0x18, 0x28, 0x85, 0x24, 0x88, 0x49, 0x23, 0x93,
+ 0xa5, 0x60, 0x04, 0x50, 0x50, 0xda, 0x0a, 0xe1,
+ 0x6e, 0x82, 0xf8, 0x18, 0x60, 0x7a, 0x14, 0x92,
+ 0x21, 0x64, 0x8a, 0x53, 0x05, 0x0d, 0xe0, 0x8c,
+ 0x16, 0xe8, 0x27, 0x01, 0x86, 0x05, 0x81, 0x49,
+ 0x22, 0x13, 0x89, 0xe0, 0xa1, 0xc4, 0x0d, 0x82,
+ 0xdd, 0x03, 0xe0, 0x30, 0xc0, 0x70, 0x29, 0x24,
+ 0x49, 0x3b, 0x01, 0x3c, 0xa6, 0x45, 0x05, 0x0e,
+ 0x60, 0x46, 0x16, 0xe8, 0x15, 0x81, 0x86, 0x01,
+ 0x21, 0x49, 0x22, 0x12, 0x08, 0xa4, 0xc2, 0x84,
+ 0x04, 0x42, 0xde, 0x75, 0x3a, 0x1c, 0x0e, 0xb0,
+ 0xff, 0x03, 0x25, 0x72, 0x44, 0x5b, 0x00, 0xf2,
+ 0xa7, 0x9d, 0x4e, 0x87, 0x03, 0xa9, 0xd2, 0xb6,
+ 0xc3, 0x53, 0x85, 0x69, 0x0e, 0xe0, 0x5e, 0x16,
+ 0x4a, 0xd3, 0x08, 0xb6, 0x6f, 0xc0, 0x65, 0xad,
+ 0x28, 0x51, 0x2b, 0x34, 0x83, 0xb8, 0x0a, 0x05,
+ 0xd6, 0x2b, 0x02, 0x2d, 0x1f, 0x4b, 0x04, 0xa4,
+ 0x10, 0xbb, 0x03, 0x0c, 0x52, 0x08, 0xf9, 0x2a,
+ 0xe3, 0x10, 0x40, 0x10, 0x2c, 0x70, 0x61, 0x2b,
+ 0xe8, 0x2a, 0x25, 0xe0, 0x31, 0x15, 0xc9, 0x68,
+ 0x0d, 0x92, 0x79, 0x03, 0x1c, 0x59, 0xc0, 0xcb,
+ 0x26, 0xd0, 0x1e, 0x88, 0x23, 0x9c, 0x00, 0xa3,
+ 0xa1, 0xbe, 0x50, 0x46, 0x0a, 0x88, 0x58, 0xd8,
+ 0xe0, 0x66, 0x57, 0x59, 0x63, 0x01, 0xbe, 0x22,
+ 0xa0, 0x0a, 0x92, 0x40, 0x18, 0xe0, 0x44, 0x57,
+ 0x51, 0x00, 0xae, 0x04, 0xe0, 0x21, 0x80, 0x90,
+ 0x1c, 0xe0, 0x52, 0x46, 0x53, 0x64, 0x10, 0x00,
+ 0x14, 0x30, 0x8b, 0x48, 0x9a, 0x4c, 0xd1, 0x13,
+ 0x2b, 0x61, 0xb2, 0x3c, 0x40, 0x74, 0x8e, 0x00,
+ 0x51, 0xa5, 0x08, 0x67, 0xb9, 0x2a, 0x38, 0x80,
+ 0xe1, 0x18, 0x40, 0x29, 0x9d, 0x0c, 0x26, 0x3a,
+ 0x6e, 0x00, 0xb6, 0x03, 0x22, 0x30, 0x9f, 0x97,
+ 0xda, 0x63, 0xd7, 0x16, 0x69, 0x00, 0x30, 0x82,
+ 0x3d, 0xdf, 0x6c, 0x8f, 0x72, 0xc2, 0xa3, 0xdd,
+ 0xd0, 0xa8, 0xe7, 0x29, 0xda, 0x02, 0x60, 0x73,
+ 0x88, 0x80, 0x5c, 0xa2, 0x6a, 0x47, 0x38, 0xe7,
+ 0x84, 0x2a, 0x39, 0xe5, 0x0a, 0x8e, 0xba, 0x42,
+ 0xa0, 0x26, 0x46, 0xc3, 0x61, 0x8e, 0x31, 0x27,
+ 0x31, 0x80, 0x18, 0x5b, 0x0d, 0x90, 0xd2, 0x03,
+ 0xa4, 0x2c, 0x02, 0x8d, 0x17, 0x43, 0x1d, 0xc2,
+ 0xb8, 0x2c, 0x71, 0x59, 0x0b, 0x84, 0x0a, 0x40,
+ 0xc7, 0x15, 0x20, 0x33, 0x45, 0x74, 0xc6, 0x10,
+ 0x0c, 0x0b, 0x61, 0xb2, 0x14, 0xc0, 0x74, 0x84,
+ 0x20, 0x51, 0xa2, 0x90, 0x63, 0xb8, 0x41, 0x05,
+ 0xda, 0x2f, 0x43, 0x7b, 0x85, 0xab, 0x08, 0x20,
+ 0x18, 0x06, 0x43, 0x29, 0xe2, 0x12, 0x02, 0x7d,
+ 0x05, 0x42, 0x71, 0x64, 0x03, 0x03, 0xc0, 0xe0,
+ 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x08, 0x49,
+ 0x81, 0xa4, 0xdd, 0x03, 0x90, 0x39, 0x1d, 0x22,
+ 0x40, 0x25, 0xc8, 0x0f, 0x01, 0xb2, 0x6d, 0x60,
+ 0x6e, 0x32, 0x99, 0x20, 0xa8, 0x07, 0x08, 0x36,
+ 0x45, 0x8e, 0x10, 0xd5, 0x30, 0x83, 0x52, 0x11,
+ 0xa1, 0xd0, 0x36, 0x93, 0x71, 0x90, 0xca, 0x78,
+ 0x81, 0x48, 0x5a, 0x4d, 0xc6, 0x43, 0x29, 0xe0,
+ 0x15, 0x02, 0x35, 0x90, 0x0c, 0x0f, 0x03, 0x81,
+ 0x80, 0xc0, 0x60, 0x30, 0x18, 0x0c, 0x20, 0x34,
+ 0x06, 0x13, 0x71, 0x90, 0x40, 0x69, 0x33, 0x42,
+ 0x2b, 0x8c, 0xa6, 0xc3, 0x9c, 0x34, 0x80, 0xdb,
+ 0x06, 0x89, 0x3b, 0x1b, 0xcd, 0x26, 0x41, 0x04,
+ 0x30, 0xc0, 0xc8, 0x69, 0x33, 0x40, 0xaa, 0x8e,
+ 0xc6, 0x93, 0x94, 0x0f, 0x00, 0xc3, 0x01, 0x90,
+ 0x36, 0xc0, 0xd4, 0x0d, 0x10, 0x8b, 0x00, 0x54,
+ 0x09, 0x14, 0xed, 0x03, 0x10, 0x39, 0xc1, 0x94,
+ 0x2e, 0x50, 0x82, 0x23, 0x9c, 0x09, 0x42, 0x15,
+ 0x02, 0x52, 0x85, 0x17, 0x60, 0x30, 0x10, 0xa8,
+ 0x15, 0x1c, 0x2a, 0x05, 0x40, 0x5b, 0x83, 0x00,
+ 0x19, 0x0d, 0x26, 0x68, 0x0b, 0x01, 0xa0, 0xd2,
+ 0x64, 0x32, 0xc1, 0x74, 0x2c, 0x70, 0xcf, 0x03,
+ 0x99, 0xd0, 0xc3, 0x04, 0xd0, 0x10, 0x1e, 0xa1,
+ 0x36, 0x06, 0xf8, 0x06, 0x84, 0xfe, 0x27, 0x62,
+ 0x22, 0x81, 0x28, 0x48, 0xa0, 0xbc, 0x06, 0xf3,
+ 0x69, 0xc2, 0x00, 0xc0, 0x65, 0x10, 0x0c, 0x07,
+ 0xb1, 0x0c, 0x19, 0xf9, 0xf4, 0xfb, 0x12, 0x10,
+ 0x11, 0x08, 0x0f, 0xa7, 0xd8, 0x30, 0x81, 0x8c,
+ 0xde, 0x6d, 0x38, 0x40, 0x50, 0x0c, 0xa2, 0x01,
+ 0x80, 0xf6, 0x1e, 0x41, 0x73, 0x83, 0x78, 0x0b,
+ 0x4c, 0x70, 0xbc, 0x03, 0x94, 0x02, 0x02, 0x15,
+ 0x0e, 0x60, 0x3d, 0x9e, 0xe0, 0x10, 0x16, 0x43,
+ 0xa9, 0xc2, 0x0c, 0xe0, 0x6f, 0x84, 0x20, 0x5c,
+ 0xcf, 0x82, 0x03, 0x74, 0x0d, 0x00, 0xc7, 0x05,
+ 0x90, 0xb7, 0xc0, 0x40, 0x2c, 0x30, 0x55, 0x01,
+ 0x01, 0xf0, 0x14, 0x62, 0x84, 0xd8, 0x1a, 0x4d,
+ 0xc0, 0xa3, 0x84, 0x09, 0x40, 0xe7, 0x06, 0xf0,
+ 0x3b, 0xc2, 0x50, 0x0c, 0x80, 0xa1, 0xfc, 0x30,
+ 0xc0, 0xe0, 0x20, 0x18, 0x0f, 0x61, 0xa4, 0x06,
+ 0x28, 0x43, 0x01, 0xd2, 0x00, 0x80, 0x45, 0x39,
+ 0x40, 0x84, 0x0e, 0x50, 0x9d, 0x03, 0x79, 0xd4,
+ 0xe9, 0x07, 0x60, 0x33, 0x08, 0x20, 0x44, 0x07,
+ 0x83, 0xa0, 0x80, 0xef, 0x01, 0xb0, 0x34, 0x42,
+ 0xf4, 0x0e, 0x90, 0xa2, 0x03, 0x29, 0x96, 0x1b,
+ 0xa1, 0x20, 0x3e, 0x9f, 0x44, 0x40, 0xa1, 0x94,
+ 0x23, 0x80, 0xe0, 0x20, 0x19, 0x42, 0x24, 0x0e,
+ 0x02, 0x01, 0xfc, 0x22, 0x42, 0x5b, 0x0f, 0xd0,
+ 0x3a, 0x08, 0x07, 0xe7, 0xd3, 0xec, 0x11, 0x04,
+ 0x60, 0x3d, 0x05, 0x1d, 0xcd, 0x06, 0x98, 0x38,
+ 0x80, 0x28, 0xdc, 0x4c, 0x87, 0x40, 0x1c, 0xc4,
+ 0x03, 0x11, 0x58, 0x80, 0xe8, 0x6f, 0x10, 0x1b,
+ 0x89, 0x90, 0xdc, 0x03, 0x98, 0x2a, 0x02, 0x60,
+ 0x70, 0x8a, 0xe0, 0x1d, 0x01, 0x43, 0xf8, 0x2b,
+ 0x85, 0xa4, 0xcc, 0x20, 0x82, 0xf0, 0x1d, 0x0d,
+ 0xf0, 0x16, 0x03, 0x7c, 0x21, 0xc2, 0xc3, 0x00,
+ 0x70, 0x10, 0x41, 0x64, 0x0c, 0x86, 0x93, 0x30,
+ 0x28, 0xdc, 0x4c, 0x85, 0xa0, 0x1c, 0xc4, 0x10,
+ 0x56, 0x03, 0x21, 0xbc, 0x14, 0x28, 0x82, 0xa8,
+ 0x18, 0xe0, 0x20, 0x02, 0x90, 0x54, 0x13, 0x80,
+ 0xde, 0x70, 0x05, 0x41, 0x24, 0x0c, 0x70, 0x60,
+ 0x03, 0x0c, 0x29, 0x00, 0x41, 0x02, 0x90, 0x1e,
+ 0x88, 0x0d, 0x26, 0x60, 0x51, 0x8a, 0x1c, 0xa0,
+ 0x69, 0x37, 0x02, 0x8e, 0x10, 0x00, 0x03, 0x9c,
+ 0x2e, 0x40, 0xef, 0x0d, 0xe0, 0x32, 0x02, 0x86,
+ 0x46, 0x43, 0xa9, 0xc0, 0x40, 0x3f, 0x3e, 0x9f,
+ 0x44, 0x03, 0x01, 0xe8, 0x28, 0xee, 0x68, 0x34,
+ 0x9b, 0x0c, 0xa0, 0xa3, 0x81, 0xbe, 0x05, 0xc0,
+ 0x70, 0x84, 0x00, 0x19, 0x44, 0x07, 0xa8, 0x28,
+ 0x01, 0xbe, 0x1d, 0x00, 0x6c, 0x82, 0xd8, 0x18,
+ 0x4d, 0x90, 0xe7, 0x03, 0x91, 0x96, 0x10, 0xe0,
+ 0x61, 0x87, 0x90, 0x0c, 0xa0, 0xa2, 0x06, 0xf3,
+ 0x80, 0x2a, 0x03, 0x00, 0x64, 0x34, 0x99, 0xa0,
+ 0x04, 0x13, 0x08, 0x64, 0x81, 0xb2, 0x07, 0x80,
+ 0x61, 0x36, 0x43, 0x20, 0x07, 0x62, 0x03, 0x49,
+ 0xb6, 0x00, 0x20, 0x64, 0x34, 0x98, 0x60, 0x72,
+ 0x02, 0x03, 0x19, 0xbc, 0xda, 0x70, 0x34, 0x9b,
+ 0x20, 0xb2, 0x06, 0xf3, 0x71, 0xb0, 0xf2, 0x0a,
+ 0x38, 0x40, 0x84, 0x0e, 0xd0, 0x32, 0x03, 0xac,
+ 0x0e, 0x00, 0xa6, 0x22, 0x10, 0x11, 0x89, 0x24,
+ 0x32, 0x61, 0x7c, 0xae, 0x41, 0x27, 0x15, 0x0b,
+ 0xe4, 0x62, 0x49, 0x30, 0x8a, 0x22, 0x10, 0x11,
+ 0x49, 0xc5, 0x62, 0x49, 0x48, 0x9e, 0x4e, 0x26,
+ 0x91, 0x49, 0xc5, 0x41, 0xf8, 0x82, 0x02, 0x40,
+ 0x6f, 0x38, 0x08, 0x0b, 0x66, 0x93, 0x34, 0x17,
+ 0x00, 0x74, 0x20, 0x39, 0x0b, 0xcd, 0xe2, 0x01,
+ 0x8c, 0x17, 0x86, 0xe4, 0x2f, 0x3b, 0x88, 0x06,
+ 0x70, 0x54, 0x1b, 0xb8, 0xbc, 0xde, 0x20, 0x19,
+ 0x41, 0x28, 0x6c, 0x50, 0x1e, 0x01, 0x00, 0xe2,
+ 0x04, 0x22, 0x3b, 0x81, 0xe8, 0x5a, 0x4d, 0xc6,
+ 0x33, 0x61, 0xd4, 0xc8, 0x65, 0x32, 0x02, 0x8e,
+ 0x42, 0xf3, 0x78, 0x80, 0xc5, 0x00, 0x40, 0x10,
+ 0x1b, 0xce, 0x10, 0x45, 0x01, 0x69, 0x98, 0xd2,
+ 0x6c, 0x32, 0x88, 0x06, 0x03, 0xd1, 0x01, 0xa4,
+ 0xcc, 0x0a, 0x34, 0x9b, 0x8c, 0x66, 0xc3, 0xa9,
+ 0x90, 0xca, 0x2d, 0x33, 0x1a, 0x4d, 0x86, 0x50,
+ 0x51, 0x94, 0xd8, 0x73, 0x32, 0x82, 0x8c, 0x87,
+ 0x23, 0x79, 0xc0, 0x15, 0x02, 0x00, 0x32, 0x1a,
+ 0x4c, 0xc0, 0xa1, 0xd8, 0x28, 0x74, 0x20, 0x34,
+ 0x9b, 0x8c, 0x66, 0xc3, 0xa9, 0x90, 0xca, 0x20,
+ 0x38, 0x40, 0x20, 0x0e, 0x66, 0x51, 0x69, 0xdc,
+ 0xde, 0x72, 0x32, 0x08, 0x0d, 0x26, 0xe3, 0x19,
+ 0xb0, 0xea, 0x64, 0x32, 0x99, 0x04, 0x03, 0xb0,
+ 0x51, 0x6c, 0xca, 0x6e, 0x32, 0x1a, 0x4c, 0xc5,
+ 0xd0, 0x50,
+ };
+
+#endif /* !FICL_WANT_LZ_SOFTCORE */
+
+
+void ficlSystemCompileSoftCore(ficlSystem *system)
{
- 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);
+ ficlVm *vm = system->vmList;
+ int returnValue;
+ ficlCell oldSourceID = vm->sourceId;
+ ficlString s;
+#if FICL_WANT_LZ_SOFTCORE
+ char *ficlSoftcoreUncompressed = NULL;
+ size_t gotUncompressedSize = 0;
+ returnValue = ficlLzUncompress(ficlSoftcoreCompressed, (unsigned char **)&ficlSoftcoreUncompressed, &gotUncompressedSize);
+ FICL_VM_ASSERT(vm, returnValue == 0);
+ FICL_VM_ASSERT(vm, gotUncompressedSize == ficlSoftcoreUncompressedSize);
+#endif /* FICL_WANT_LZ_SOFTCORE */
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_POINTER(s, (char *)(ficlSoftcoreUncompressed));
+ FICL_STRING_SET_LENGTH(s, ficlSoftcoreUncompressedSize);
+ returnValue = ficlVmExecuteString(vm, s);
+ vm->sourceId = oldSourceID;
+#if FICL_WANT_LZ_SOFTCORE
+ free(ficlSoftcoreUncompressed);
+#endif /* FICL_WANT_LZ_SOFTCORE */
+ FICL_VM_ASSERT(vm, returnValue != FICL_VM_STATUS_ERROR_EXIT);
return;
}
-
-
+/* end-of-file */
diff --git a/softwords/classes.fr b/softcore/classes.fr
index 1a00cc95b913..44a486322086 100644
--- a/softwords/classes.fr
+++ b/softcore/classes.fr
@@ -1,172 +1,172 @@
-\ #if (FICL_WANT_OOP)
-\ ** ficl/softwords/classes.fr
-\ ** F I C L 2 . 0 C L A S S E S
-\ john sadler 1 sep 98
-\ Needs oop.fr
-
-.( loading ficl utility classes ) cr
-also oop definitions
-
-\ REF subclass holds a pointer to an object. It's
-\ mainly for aggregation to help in making data structures.
-\
-object subclass c-ref
- cell: .class
- cell: .instance
-
- : get ( inst class -- refinst refclass )
- drop 2@ ;
- : set ( refinst refclass inst class -- )
- drop 2! ;
-end-class
-
-object subclass c-byte
- char: .payload
-
- : get drop c@ ;
- : set drop c! ;
-end-class
-
-object subclass c-2byte
- 2 chars: .payload
-
- : get drop w@ ;
- : set drop w! ;
-end-class
-
-object subclass c-4byte
- 4 chars: .payload
-
- : get drop q@ ;
- : set drop q! ;
-end-class
-
-
-object subclass c-cell
- cell: .payload
-
- : get drop @ ;
- : set drop ! ;
-end-class
-
-
-\ ** C - P T R
-\ Base class for pointers to scalars (not objects).
-\ Note: use c-ref to make references to objects. C-ptr
-\ subclasses refer to untyped quantities of various sizes.
-
-\ Derived classes must specify the size of the thing
-\ they point to, and supply get and set methods.
-
-\ All derived classes must define the @size method:
-\ @size ( inst class -- addr-units )
-\ Returns the size in address units of the thing the pointer
-\ refers to.
-object subclass c-ptr
- c-cell obj: .addr
-
- \ get the value of the pointer
- : get-ptr ( inst class -- addr )
- c-ptr => .addr
- c-cell => get
- ;
-
- \ set the pointer to address supplied
- : set-ptr ( addr inst class -- )
- c-ptr => .addr
- c-cell => set
- ;
-
- \ force the pointer to be null
- : clr-ptr
- 0 -rot c-ptr => .addr c-cell => set
- ;
-
- \ return flag indicating null-ness
- : ?null ( inst class -- flag )
- c-ptr => get-ptr 0=
- ;
-
- \ increment the pointer in place
- : inc-ptr ( inst class -- )
- 2dup 2dup ( i c i c i c )
- c-ptr => get-ptr -rot ( i c addr i c )
- --> @size + -rot ( addr' i c )
- c-ptr => set-ptr
- ;
-
- \ decrement the pointer in place
- : dec-ptr ( inst class -- )
- 2dup 2dup ( i c i c i c )
- c-ptr => get-ptr -rot ( i c addr i c )
- --> @size - -rot ( addr' i c )
- c-ptr => set-ptr
- ;
-
- \ index the pointer in place
- : index-ptr { index 2:this -- }
- this --> get-ptr ( addr )
- this --> @size index * + ( addr' )
- this --> set-ptr
- ;
-
-end-class
-
-
-\ ** C - C E L L P T R
-\ Models a pointer to cell (a 32 or 64 bit scalar).
-c-ptr subclass c-cellPtr
- : @size 2drop 1 cells ;
- \ fetch and store through the pointer
- : get ( inst class -- cell )
- c-ptr => get-ptr @
- ;
- : set ( value inst class -- )
- c-ptr => get-ptr !
- ;
-end-class
-
-
-\ ** C - 4 B Y T E P T R
-\ Models a pointer to a quadbyte scalar
-c-ptr subclass c-4bytePtr
- : @size 2drop 4 ;
- \ fetch and store through the pointer
- : get ( inst class -- value )
- c-ptr => get-ptr q@
- ;
- : set ( value inst class -- )
- c-ptr => get-ptr q!
- ;
- end-class
-
-\ ** C - 2 B Y T E P T R
-\ Models a pointer to a 16 bit scalar
-c-ptr subclass c-2bytePtr
- : @size 2drop 2 ;
- \ fetch and store through the pointer
- : get ( inst class -- value )
- c-ptr => get-ptr w@
- ;
- : set ( value inst class -- )
- c-ptr => get-ptr w!
- ;
-end-class
-
-
-\ ** C - B Y T E P T R
-\ Models a pointer to an 8 bit scalar
-c-ptr subclass c-bytePtr
- : @size 2drop 1 ;
- \ fetch and store through the pointer
- : get ( inst class -- value )
- c-ptr => get-ptr c@
- ;
- : set ( value inst class -- )
- c-ptr => get-ptr c!
- ;
-end-class
-
-
-previous definitions
-\ #endif
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** ficl/softwords/classes.fr
+\ ** F I C L 2 . 0 C L A S S E S
+\ john sadler 1 sep 98
+\ Needs oop.fr
+
+.( loading ficl utility classes ) cr
+also oop definitions
+
+\ REF subclass holds a pointer to an object. It's
+\ mainly for aggregation to help in making data structures.
+\
+object subclass c-ref
+ cell: .class
+ cell: .instance
+
+ : get ( inst class -- refinst refclass )
+ drop 2@ ;
+ : set ( refinst refclass inst class -- )
+ drop 2! ;
+end-class
+
+object subclass c-byte
+ char: .payload
+
+ : get drop c@ ;
+ : set drop c! ;
+end-class
+
+object subclass c-2byte
+ 2 chars: .payload
+
+ : get drop w@ ;
+ : set drop w! ;
+end-class
+
+object subclass c-4byte
+ 4 chars: .payload
+
+ : get drop q@ ;
+ : set drop q! ;
+end-class
+
+
+object subclass c-cell
+ cell: .payload
+
+ : get drop @ ;
+ : set drop ! ;
+end-class
+
+
+\ ** C - P T R
+\ Base class for pointers to scalars (not objects).
+\ Note: use c-ref to make references to objects. C-ptr
+\ subclasses refer to untyped quantities of various sizes.
+
+\ Derived classes must specify the size of the thing
+\ they point to, and supply get and set methods.
+
+\ All derived classes must define the @size method:
+\ @size ( inst class -- addr-units )
+\ Returns the size in address units of the thing the pointer
+\ refers to.
+object subclass c-ptr
+ c-cell obj: .addr
+
+ \ get the value of the pointer
+ : get-ptr ( inst class -- addr )
+ c-ptr => .addr
+ c-cell => get
+ ;
+
+ \ set the pointer to address supplied
+ : set-ptr ( addr inst class -- )
+ c-ptr => .addr
+ c-cell => set
+ ;
+
+ \ force the pointer to be null
+ : clr-ptr
+ 0 -rot c-ptr => .addr c-cell => set
+ ;
+
+ \ return flag indicating null-ness
+ : ?null ( inst class -- flag )
+ c-ptr => get-ptr 0=
+ ;
+
+ \ increment the pointer in place
+ : inc-ptr ( inst class -- )
+ 2dup 2dup ( i c i c i c )
+ c-ptr => get-ptr -rot ( i c addr i c )
+ --> @size + -rot ( addr' i c )
+ c-ptr => set-ptr
+ ;
+
+ \ decrement the pointer in place
+ : dec-ptr ( inst class -- )
+ 2dup 2dup ( i c i c i c )
+ c-ptr => get-ptr -rot ( i c addr i c )
+ --> @size - -rot ( addr' i c )
+ c-ptr => set-ptr
+ ;
+
+ \ index the pointer in place
+ : index-ptr { index 2:this -- }
+ this --> get-ptr ( addr )
+ this --> @size index * + ( addr' )
+ this --> set-ptr
+ ;
+
+end-class
+
+
+\ ** C - C E L L P T R
+\ Models a pointer to cell (a 32 or 64 bit scalar).
+c-ptr subclass c-cellPtr
+ : @size 2drop 1 cells ;
+ \ fetch and store through the pointer
+ : get ( inst class -- cell )
+ c-ptr => get-ptr @
+ ;
+ : set ( value inst class -- )
+ c-ptr => get-ptr !
+ ;
+end-class
+
+
+\ ** C - 4 B Y T E P T R
+\ Models a pointer to a quadbyte scalar
+c-ptr subclass c-4bytePtr
+ : @size 2drop 4 ;
+ \ fetch and store through the pointer
+ : get ( inst class -- value )
+ c-ptr => get-ptr q@
+ ;
+ : set ( value inst class -- )
+ c-ptr => get-ptr q!
+ ;
+ end-class
+
+\ ** C - 2 B Y T E P T R
+\ Models a pointer to a 16 bit scalar
+c-ptr subclass c-2bytePtr
+ : @size 2drop 2 ;
+ \ fetch and store through the pointer
+ : get ( inst class -- value )
+ c-ptr => get-ptr w@
+ ;
+ : set ( value inst class -- )
+ c-ptr => get-ptr w!
+ ;
+end-class
+
+
+\ ** C - B Y T E P T R
+\ Models a pointer to an 8 bit scalar
+c-ptr subclass c-bytePtr
+ : @size 2drop 1 ;
+ \ fetch and store through the pointer
+ : get ( inst class -- value )
+ c-ptr => get-ptr c@
+ ;
+ : set ( value inst class -- )
+ c-ptr => get-ptr c!
+ ;
+end-class
+
+
+previous definitions
+[endif]
diff --git a/softcore/ficl.fr b/softcore/ficl.fr
new file mode 100644
index 000000000000..d90bd3b16957
--- /dev/null
+++ b/softcore/ficl.fr
@@ -0,0 +1,67 @@
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+S" FICL_WANT_USER" ENVIRONMENT? drop [if]
+\ ** Ficl USER variables
+\ ** See words.c for primitive def'n of USER
+variable nUser 0 nUser !
+: user \ name ( -- )
+ nUser dup @ user 1 swap +! ;
+
+[endif]
+
+
+
+S" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
+
+\ ** LOCAL EXT word set
+
+: locals| ( name...name | -- )
+ begin
+ bl word count
+ dup 0= abort" where's the delimiter??"
+ over c@
+ [char] | - over 1- or
+ while
+ (local)
+ repeat 2drop 0 0 (local)
+; immediate
+
+: local ( name -- ) bl word count (local) ; immediate
+
+: 2local ( name -- ) bl word count (2local) ; immediate
+
+: end-locals ( -- ) 0 0 (local) ; immediate
+
+
+\ 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
+ ;
+
+[endif]
+
+\ end-of-file
+
diff --git a/softwords/ficlclass.fr b/softcore/ficlclass.fr
index 5922c6e19aae..35cf31982cbe 100644
--- a/softwords/ficlclass.fr
+++ b/softcore/ficlclass.fr
@@ -1,84 +1,84 @@
-\ #if (FICL_WANT_OOP)
-\ ** ficl/softwords/ficlclass.fr
-\ Classes to model ficl data structures in objects
-\ This is a demo!
-\ John Sadler 14 Sep 1998
-\
-\ ** C - W O R D
-\ Models a FICL_WORD
-
-object subclass c-word
- c-word ref: .link
- c-2byte obj: .hashcode
- c-byte obj: .flags
- c-byte obj: .nName
- c-bytePtr obj: .pName
- c-cellPtr obj: .pCode
- c-4byte obj: .param0
-
- \ Push word's name...
- : get-name ( inst class -- c-addr u )
- 2dup
- my=[ .pName get-ptr ] -rot
- my=[ .nName get ]
- ;
-
- : next ( inst class -- link-inst class )
- my=> .link ;
-
- : ?
- ." c-word: "
- 2dup --> get-name type cr
- ;
-
-end-class
-
-\ ** C - W O R D L I S T
-\ Models a FICL_HASH
-\ Example of use:
-\ get-current c-wordlist --> ref current
-\ current --> ?
-\ current --> .hash --> ?
-\ current --> .hash --> next --> ?
-
-object subclass c-wordlist
- c-wordlist ref: .parent
- c-ptr obj: .name
- c-cell obj: .size
- c-word ref: .hash ( first entry in hash table )
-
- : ?
- --> get-name ." ficl wordlist " type cr ;
- : push drop >search ;
- : pop 2drop previous ;
- : set-current drop set-current ;
- : get-name drop wid-get-name ;
- : words { 2:this -- }
- this my=[ .size get ] 0 do
- i this my=[ .hash index ] ( 2list-head )
- begin
- 2dup --> get-name type space
- --> next over
- 0= until 2drop cr
- loop
- ;
-end-class
-
-\ : named-wid wordlist postpone c-wordlist metaclass => ref ;
-
-
-\ ** C - F I C L S T A C K
-object subclass c-ficlstack
- c-4byte obj: .nCells
- c-cellPtr obj: .link
- c-cellPtr obj: .sp
- c-4byte obj: .stackBase
-
- : init 2drop ;
- : ? 2drop
- ." ficl stack " cr ;
- : top
- --> .sp --> .addr --> prev --> get ;
-end-class
-
-\ #endif
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** ficl/softwords/ficlclass.fr
+\ Classes to model ficl data structures in objects
+\ This is a demo!
+\ John Sadler 14 Sep 1998
+\
+\ ** C - W O R D
+\ Models a FICL_WORD
+
+object subclass c-word
+ c-word ref: .link
+ c-2byte obj: .hashcode
+ c-byte obj: .flags
+ c-byte obj: .nName
+ c-bytePtr obj: .pName
+ c-cellPtr obj: .pCode
+ c-4byte obj: .param0
+
+ \ Push word's name...
+ : get-name ( inst class -- c-addr u )
+ 2dup
+ my=[ .pName get-ptr ] -rot
+ my=[ .nName get ]
+ ;
+
+ : next ( inst class -- link-inst class )
+ my=> .link ;
+
+ : ?
+ ." c-word: "
+ 2dup --> get-name type cr
+ ;
+
+end-class
+
+\ ** C - W O R D L I S T
+\ Models a FICL_HASH
+\ Example of use:
+\ get-current c-wordlist --> ref current
+\ current --> ?
+\ current --> .hash --> ?
+\ current --> .hash --> next --> ?
+
+object subclass c-wordlist
+ c-wordlist ref: .parent
+ c-ptr obj: .name
+ c-cell obj: .size
+ c-word ref: .hash ( first entry in hash table )
+
+ : ?
+ --> get-name ." ficl wordlist " type cr ;
+ : push drop >search ;
+ : pop 2drop previous ;
+ : set-current drop set-current ;
+ : get-name drop wid-get-name ;
+ : words { 2:this -- }
+ this my=[ .size get ] 0 do
+ i this my=[ .hash index ] ( 2list-head )
+ begin
+ 2dup --> get-name type space
+ --> next over
+ 0= until 2drop cr
+ loop
+ ;
+end-class
+
+\ : named-wid wordlist postpone c-wordlist metaclass => ref ;
+
+
+\ ** C - F I C L S T A C K
+object subclass c-ficlstack
+ c-4byte obj: .nCells
+ c-cellPtr obj: .link
+ c-cellPtr obj: .sp
+ c-4byte obj: .stackBase
+
+ : init 2drop ;
+ : ? 2drop
+ ." ficl stack " cr ;
+ : top
+ --> .sp --> .addr --> prev --> get ;
+end-class
+
+[endif]
diff --git a/softwords/ficllocal.fr b/softcore/ficllocal.fr
index 9381247edfc4..bd8a24bdec73 100644
--- a/softwords/ficllocal.fr
+++ b/softcore/ficllocal.fr
@@ -1,46 +1,46 @@
-\ ** ficl/softwords/ficllocal.fr
-\ ** stack comment style local syntax...
-\ {{ a b c -- d e }}
-\ variables before the "--" are initialized in reverse order
-\ from the stack. Those after the "--" are zero initialized
-\ Uses locals...
-\ locstate: 0 = looking for -- or }}
-\ 1 = found --
-hide
-0 constant zero
-
-: ?-- s" --" compare 0= ;
-: ?}} s" }}" compare 0= ;
-
-set-current
-
-: {{
- 0 dup locals| nLocs locstate |
- begin
- parse-word
- ?dup 0= abort" Error: out of text without seeing }}"
- 2dup 2dup ?-- -rot ?}} or 0=
- while
- nLocs 1+ to nLocs
- repeat
-
- ?-- if 1 to locstate endif
-
- nLocs 0 do
- (local)
- loop
-
- locstate 1 = if
- begin
- parse-word
- 2dup ?}} 0=
- while
- postpone zero (local)
- repeat
- 2drop
- endif
-
- 0 0 (local)
-; immediate compile-only
-
-previous
+\ ** ficl/softwords/ficllocal.fr
+\ ** stack comment style local syntax...
+\ {{ a b c -- d e }}
+\ variables before the "--" are initialized in reverse order
+\ from the stack. Those after the "--" are zero initialized
+\ Uses locals...
+\ locstate: 0 = looking for -- or }}
+\ 1 = found --
+hide
+0 constant zero
+
+: ?-- s" --" compare 0= ;
+: ?}} s" }}" compare 0= ;
+
+set-current
+
+: {{
+ 0 dup locals| nLocs locstate |
+ begin
+ parse-word
+ ?dup 0= abort" Error: out of text without seeing }}"
+ 2dup 2dup ?-- -rot ?}} or 0=
+ while
+ nLocs 1+ to nLocs
+ repeat
+
+ ?-- if 1 to locstate endif
+
+ nLocs 0 do
+ (local)
+ loop
+
+ locstate 1 = if
+ begin
+ parse-word
+ 2dup ?}} 0=
+ while
+ postpone zero (local)
+ repeat
+ 2drop
+ endif
+
+ 0 0 (local)
+; immediate compile-only
+
+previous
diff --git a/softwords/fileaccess.fr b/softcore/fileaccess.fr
index 7a4452ac7e75..2673fefc0767 100644
--- a/softwords/fileaccess.fr
+++ b/softcore/fileaccess.fr
@@ -1,23 +1,22 @@
-\ #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
- else
- drop
- endif
- ;
-
-: include parse-word included ;
-
-\ #endif
+S" FICL_WANT_FILE" ENVIRONMENT? drop [if]
+\ **
+\ ** 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
+ include-file
+ else
+ drop
+ endif
+ ;
+
+: include parse-word included ;
+
+[endif]
diff --git a/softwords/forml.fr b/softcore/forml.fr
index cc684e086131..a26480b94698 100644
--- a/softwords/forml.fr
+++ b/softcore/forml.fr
@@ -1,72 +1,72 @@
-\ examples from FORML conference paper Nov 98
-\ sadler
-.( loading FORML examples ) cr
-object --> sub c-example
- cell: .cell0
- c-4byte obj: .nCells
- 4 c-4byte array: .quad
- c-byte obj: .length
- 79 chars: .name
-
- : init ( inst class -- )
- 2dup object => init
- s" aardvark" 2swap --> set-name
- ;
-
- : get-name ( inst class -- c-addr u )
- 2dup
- --> .name -rot ( c-addr inst class )
- --> .length --> get
- ;
-
- : set-name { c-addr u 2:this -- }
- u this --> .length --> set
- c-addr this --> .name u move
- ;
-
- : ? ( inst class ) c-example => get-name type cr ;
-end-class
-
-
-: test ." this is a test" cr ;
-' test
-c-word --> ref testref
-
-\ add a method to c-word...
-c-word --> get-wid ficl-set-current
-\ list dictionary thread
-: list ( inst class )
- begin
- 2dup --> get-name type cr
- --> next over
- 0= until
- 2drop
-;
-set-current
-
-object subclass c-led
- c-byte obj: .state
-
- : on { led# 2:this -- }
- this --> .state --> get
- 1 led# lshift or dup !oreg
- this --> .state --> set
- ;
-
- : off { led# 2:this -- }
- this --> .state --> get
- 1 led# lshift invert and dup !oreg
- this --> .state --> set
- ;
-
-end-class
-
-
-object subclass c-switch
-
- : ?on { bit# 2:this -- flag }
-
- 1 bit# lshift
- ;
-end-class
-
+\ examples from FORML conference paper Nov 98
+\ sadler
+.( loading FORML examples ) cr
+object --> sub c-example
+ cell: .cell0
+ c-4byte obj: .nCells
+ 4 c-4byte array: .quad
+ c-byte obj: .length
+ 79 chars: .name
+
+ : init ( inst class -- )
+ 2dup object => init
+ s" aardvark" 2swap --> set-name
+ ;
+
+ : get-name ( inst class -- c-addr u )
+ 2dup
+ --> .name -rot ( c-addr inst class )
+ --> .length --> get
+ ;
+
+ : set-name { c-addr u 2:this -- }
+ u this --> .length --> set
+ c-addr this --> .name u move
+ ;
+
+ : ? ( inst class ) c-example => get-name type cr ;
+end-class
+
+
+: test ." this is a test" cr ;
+' test
+c-word --> ref testref
+
+\ add a method to c-word...
+c-word --> get-wid ficl-set-current
+\ list dictionary thread
+: list ( inst class )
+ begin
+ 2dup --> get-name type cr
+ --> next over
+ 0= until
+ 2drop
+;
+set-current
+
+object subclass c-led
+ c-byte obj: .state
+
+ : on { led# 2:this -- }
+ this --> .state --> get
+ 1 led# lshift or dup !oreg
+ this --> .state --> set
+ ;
+
+ : off { led# 2:this -- }
+ this --> .state --> get
+ 1 led# lshift invert and dup !oreg
+ this --> .state --> set
+ ;
+
+end-class
+
+
+object subclass c-switch
+
+ : ?on { bit# 2:this -- flag }
+
+ 1 bit# lshift
+ ;
+end-class
+
diff --git a/softwords/ifbrack.fr b/softcore/ifbrack.fr
index af276b8e0947..35c9e72b724d 100644
--- a/softwords/ifbrack.fr
+++ b/softcore/ifbrack.fr
@@ -1,48 +1,48 @@
-\ ** ficl/softwords/ifbrack.fr
-\ ** ANS conditional compile directives [if] [else] [then]
-\ ** Requires ficl 2.0 or greater...
-
-hide
-
-: ?[if] ( c-addr u -- c-addr u flag )
- 2dup s" [if]" compare-insensitive 0=
-;
-
-: ?[else] ( c-addr u -- c-addr u flag )
- 2dup s" [else]" compare-insensitive 0=
-;
-
-: ?[then] ( c-addr u -- c-addr u flag )
- 2dup s" [then]" compare-insensitive 0= >r
- 2dup s" [endif]" compare-insensitive 0= r>
- or
-;
-
-set-current
-
-: [else] ( -- )
- 1 \ ( level )
- begin
- begin
- parse-word dup while \ ( level addr len )
- ?[if] if \ ( level addr len )
- 2drop 1+ \ ( level )
- else \ ( level addr len )
- ?[else] if \ ( level addr len )
- 2drop 1- dup if 1+ endif
- else
- ?[then] if 2drop 1- else 2drop endif
- endif
- endif ?dup 0= if exit endif \ level
- repeat 2drop \ level
- refill 0= until \ level
- drop
-; immediate
-
-: [if] ( flag -- )
-0= if postpone [else] then ; immediate
-
-: [then] ( -- ) ; immediate
-: [endif] ( -- ) ; immediate
-
-previous
+\ ** ficl/softwords/ifbrack.fr
+\ ** ANS conditional compile directives [if] [else] [then]
+\ ** Requires ficl 2.0 or greater...
+
+hide
+
+: ?[if] ( c-addr u -- c-addr u flag )
+ 2dup s" [if]" compare-insensitive 0=
+;
+
+: ?[else] ( c-addr u -- c-addr u flag )
+ 2dup s" [else]" compare-insensitive 0=
+;
+
+: ?[then] ( c-addr u -- c-addr u flag )
+ 2dup s" [then]" compare-insensitive 0= >r
+ 2dup s" [endif]" compare-insensitive 0= r>
+ or
+;
+
+set-current
+
+: [else] ( -- )
+ 1 \ ( level )
+ begin
+ begin
+ parse-word dup while \ ( level addr len )
+ ?[if] if \ ( level addr len )
+ 2drop 1+ \ ( level )
+ else \ ( level addr len )
+ ?[else] if \ ( level addr len )
+ 2drop 1- dup if 1+ endif
+ else
+ ?[then] if 2drop 1- else 2drop endif
+ endif
+ endif ?dup 0= if exit endif \ level
+ repeat 2drop \ level
+ refill 0= until \ level
+ drop
+; immediate
+
+: [if] ( flag -- )
+0= if postpone [else] then ; immediate
+
+: [then] ( -- ) ; immediate
+: [endif] ( -- ) ; immediate
+
+previous
diff --git a/softcore/jhlocal.fr b/softcore/jhlocal.fr
new file mode 100644
index 000000000000..775ecf5d9f76
--- /dev/null
+++ b/softcore/jhlocal.fr
@@ -0,0 +1,171 @@
+S" FICL_WANT_LOCALS" ENVIRONMENT? drop [if]
+\ ** ficl/softwords/jhlocal.fr
+\ ** stack comment style local syntax...
+\ { a b c | cleared -- d e }
+\ variables before the "|" are initialized in reverse order
+\ from the stack. Those after the "|" are zero initialized.
+\ Anything between "--" and "}" is treated as comment
+\ Uses locals...
+\ locstate: 0 = looking for | or -- or }}
+\ 1 = found |
+\ 2 = found --
+\ 3 = found }
+\ 4 = end of line
+\
+\ revised 2 June 2000 - { | a -- } now works correctly
+.( loading Johns-Hopkins locals ) cr
+hide
+
+\ What does this do? It's equivalent to "postpone 0", but faster.
+\ "ficlInstruction0" is the FICL instruction for "push a 0 on the data stack".
+\ --lch
+: compiled-zero ficlInstruction0 , ;
+\ And this is the instruction for a floating-point 0 (0.0e).
+: compiled-float-zero ficlInstructionF0 , ;
+
+
+: ?-- ( c-addr u -- c-addr u flag )
+ 2dup s" --" compare 0= ;
+: ?} ( c-addr u -- c-addr u flag )
+ 2dup s" }" compare 0= ;
+: ?| ( c-addr u -- c-addr u flag )
+ 2dup s" |" compare 0= ;
+
+1 constant local-is-double
+2 constant local-is-float
+
+\ parse-local-prefix-flags
+\
+\ Parses single-letter prefix flags from the name of a local, and returns
+\ a bitfield of all flags (local-is-float | local-is-double) appropriate
+\ for the local. Adjusts the "c-addr u" of the name to remove any prefix.
+\
+\ Handled single-letter prefix flags:
+\ 1 single-cell
+\ 2 double-cell
+\ d double-cell
+\ f floating-point (use floating stack)
+\ i integer (use data stack)
+\ s single-cell
+\ Specify as many as you like; later flags have precidence.
+\ Thus, "f2:foo" and "2is2f:foo" are both double-cell floats.
+\
+\ If you don't specify anything after the colon, like "f2:",
+\ there is no legal prefix, so "2f:" becomes the name of the
+\ (single-cell data stack) local.
+\
+\ For convention, the "f" is preferred first.
+
+: parse-local-prefix-flags ( c-addr u -- c-addr u flags )
+ 0 0 0 locals| stop-loop colon-offset flags u c-addr |
+
+ \ if the first character is a colon, remove the colon and return 0.
+ c-addr c@ [char] : =
+ if
+ over over 0 exit
+ endif
+
+ u 0 do
+ c-addr i + c@
+ case
+ [char] 1 of flags local-is-double invert and to flags endof
+ [char] 2 of flags local-is-double or to flags endof
+ [char] d of flags local-is-double or to flags endof
+ [char] f of flags local-is-float or to flags endof
+ [char] i of flags local-is-float invert and to flags endof
+ [char] s of flags local-is-double invert and to flags endof
+ [char] : of i 1+ to colon-offset 1 to stop-loop endof
+ 1 to stop-loop
+ endcase
+ stop-loop if leave endif
+ loop
+
+ colon-offset 0=
+ colon-offset u =
+ or
+ if
+\ ." Returning variable name -- " c-addr u type ." -- No flags." cr
+ c-addr u 0 exit
+ endif
+
+ c-addr colon-offset +
+ u colon-offset -
+\ ." Returning variable name -- " 2dup type ." -- Flags: " flags . cr
+ flags
+;
+
+: ?delim ( c-addr u -- state | c-addr u 0 )
+ ?| if 2drop 1 exit endif
+ ?-- if 2drop 2 exit endif
+ ?} if 2drop 3 exit endif
+ dup 0=
+ if 2drop 4 exit endif
+ 0
+;
+
+
+
+set-current
+
+: {
+ 0 0 0 locals| flags local-state nLocals |
+
+ \ stack locals until we hit a delimiter
+ begin
+ parse-word ?delim dup to local-state
+ 0= while
+ nLocals 1+ to nLocals
+ repeat
+
+ \ now unstack the locals
+ nLocals 0 ?do
+ parse-local-prefix-flags to flags
+ flags local-is-double and if
+ flags local-is-float and if (f2local) else (2local) endif
+ else
+ flags local-is-float and if (flocal) else (local) endif
+ endif
+ loop \ ( )
+
+ \ zero locals until -- or }
+ local-state 1 = if
+ begin
+ parse-word
+ ?delim dup to local-state
+ 0= while
+ parse-local-prefix-flags to flags
+ flags local-is-double and if
+ flags local-is-float and if
+ compiled-float-zero compiled-float-zero (f2local)
+ else
+ compiled-zero compiled-zero (2local)
+ endif
+ else
+ flags local-is-float and if
+ compiled-float-zero (flocal)
+ else
+ compiled-zero (local)
+ endif
+ endif
+ repeat
+ endif
+
+ 0 0 (local)
+
+ \ toss words until }
+ \ (explicitly allow | and -- in the comment)
+ local-state 2 = if
+ begin
+ parse-word
+ ?delim dup to local-state
+ 3 < while
+ local-state 0= if 2drop endif
+ repeat
+ endif
+
+ local-state 3 <> abort" syntax error in { } local line"
+; immediate compile-only
+
+previous
+[endif]
+
diff --git a/softcore/make.bat b/softcore/make.bat
new file mode 100644
index 000000000000..8dedfc0830eb
--- /dev/null
+++ b/softcore/make.bat
@@ -0,0 +1,22 @@
+@echo off
+
+if "%1" == "clean" goto CLEAN
+
+if exist makesoftcore.exe goto SKIPCL
+cl /Zi /Od makesoftcore.c ..\lzcompress.c ..\bit.c
+goto MAKESOFTCORE
+
+:SKIPCL
+echo makesoftcore.exe exists, skipping building it.
+
+:MAKESOFTCORE
+echo on
+makesoftcore softcore.fr ifbrack.fr prefix.fr ficl.fr jhlocal.fr marker.fr oo.fr classes.fr string.fr win32.fr ficllocal.fr fileaccess.fr
+goto EXIT
+
+:CLEAN
+del *.obj
+del makesoftcore.exe
+del ..\softcore.c
+
+:EXIT
diff --git a/softcore/makefile b/softcore/makefile
new file mode 100644
index 000000000000..d686f17a62fb
--- /dev/null
+++ b/softcore/makefile
@@ -0,0 +1,11 @@
+SOURCES = softcore.fr ifbrack.fr prefix.fr ficl.fr jhlocal.fr marker.fr oo.fr classes.fr string.fr ficllocal.fr fileaccess.fr
+
+../softcore.c: makesoftcore $(SOURCES)
+ makesoftcore $(SOURCES)
+
+makesoftcore: makesoftcore.c ../lzcompress.c ../bit.c
+ $(CC) $(CFLAGS) $(CPPFLAGS) -I.. -o makesoftcore makesoftcore.c ../lzcompress.c ../bit.c
+
+clean:
+ - rm ../softcore.c *.o makesoftcore
+
diff --git a/softcore/makesoftcore.c b/softcore/makesoftcore.c
new file mode 100644
index 000000000000..090e2cddd10c
--- /dev/null
+++ b/softcore/makesoftcore.c
@@ -0,0 +1,244 @@
+/*
+** Ficl softcore generator.
+** Generates both uncompressed and Lempel-Ziv compressed versions.
+** Strips blank lines, strips full-line comments, collapses whitespace.
+** Chops, blends, dices, makes julienne fries.
+**
+** Contributed by Larry Hastings, larry@hastings.org
+**/
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+#include "ficl.h"
+
+
+#ifndef SOFTCORE_OUT
+#define SOFTCORE_OUT "../softcore.c"
+#endif
+
+void fprintDataAsHex(FILE *f, char *data, int length)
+ {
+ int i;
+ while (length)
+ {
+ fprintf(f, "\t");
+ for (i = 0; (i < 8) && length; i++)
+ {
+ char buf[16];
+ /* if you don't do this little stuff, you get ugly sign-extended 0xFFFFFF6b crap. */
+ sprintf(buf, "%08x", (unsigned int)*data++);
+ fprintf(f, "0x%s, ", buf + 6);
+ length--;
+ }
+ fprintf(f, "\n");
+ }
+ }
+
+void fprintDataAsQuotedString(FILE *f, char *data)
+ {
+ int i;
+ int lineIsBlank = 1; /* true */
+
+ while (*data)
+ {
+ if (*data == '\n')
+ {
+ if (!lineIsBlank)
+ fprintf(f, "\\n\"\n");
+ lineIsBlank = 1; /* true */
+ }
+ else
+ {
+ if (lineIsBlank)
+ {
+ fputc('\t', f);
+ fputc('"', f);
+ lineIsBlank = 0; /* false */
+ }
+
+ if (*data == '"')
+ fprintf(f, "\\\"");
+ else if (*data == '\\')
+ fprintf(f, "\\\\");
+ else
+ fputc(*data, f);
+ }
+ data++;
+ }
+ if (!lineIsBlank)
+ fprintf(f, "\"");
+ }
+
+int main(int argc, char *argv[])
+ {
+ char *uncompressed = (char *)malloc(128 * 1024);
+ unsigned char *compressed;
+ char *trace = uncompressed;
+ int i;
+ size_t compressedSize;
+ size_t uncompressedSize;
+ char *src, *dst;
+ FILE *f;
+ time_t currentTimeT;
+ struct tm *currentTime;
+ char cleverTime[32];
+
+ time(&currentTimeT);
+ currentTime = localtime(&currentTimeT);
+ strftime(cleverTime, sizeof(cleverTime), "%Y/%m/%d %H:%M:%S", currentTime);
+
+ *trace++ = ' ';
+
+ for (i = 1; i < argc; i++)
+ {
+ int size;
+ /*
+ ** This ensures there's always whitespace space between files. It *also*
+ ** ensures that src[-1] is always safe in comment detection code below.
+ ** (Any leading whitespace will be thrown away in a later pass.)
+ ** --lch
+ */
+ *trace++ = ' ';
+
+ f = fopen(argv[i], "rb");
+ fseek(f, 0, SEEK_END);
+ size = ftell(f);
+ fseek(f, 0, SEEK_SET);
+ fread(trace, 1, size, f);
+ fclose(f);
+ trace += size;
+ }
+ *trace = 0;
+
+#define IS_EOL(x) ((*x == '\n') || (*x == '\r'))
+#define IS_EOL_COMMENT(x) (((x[0] == '\\') && isspace(x[1])) || ((x[0] == '/') && (x[1] == '/') && isspace(x[2])))
+#define IS_BLOCK_COMMENT(x) ((x[0] == '(') && isspace(x[1]) && isspace(x[-1]))
+
+ src = dst = uncompressed;
+ while (*src)
+ {
+ /* ignore leading whitespace, or entirely blank lines */
+ while (isspace(*src))
+ src++;
+ /* if the line is commented out */
+ if (IS_EOL_COMMENT(src))
+ {
+ /* throw away this entire line */
+ while (*src && !IS_EOL(src))
+ src++;
+ continue;
+ }
+ /*
+ ** This is where we'd throw away mid-line comments, but
+ ** that's simply unsafe. Things like
+ ** start-prefixes
+ ** : \ postpone \ ;
+ ** : ( postpone ( ;
+ ** get broken that way.
+ ** --lch
+ */
+ while (*src && !IS_EOL(src))
+ {
+ *dst++ = *src++;
+ }
+
+ /* strip trailing whitespace */
+ dst--;
+ while (isspace(*dst))
+ dst--;
+ dst++;
+
+ /* and end the line */
+ *dst++ = '\n';
+ }
+
+ *dst = 0;
+
+ /* now make a second pass to collapse all contiguous whitespace to a single space. */
+ src = dst = uncompressed;
+ while (*src)
+ {
+ *dst++ = *src;
+ if (!isspace(*src))
+ src++;
+ else
+ {
+ while (isspace(*src))
+ src++;
+ }
+ }
+ *dst = 0;
+
+ f = fopen(SOFTCORE_OUT, "wt");
+ if (f == NULL)
+ {
+ printf("couldn't open " SOFTCORE_OUT " for writing! giving up.\n");
+ exit(-1);
+ }
+
+ fprintf(f,
+"/*\n"
+"** Ficl softcore\n"
+"** both uncompressed and Lempel-Ziv compressed versions.\n"
+"**\n"
+"** Generated %s\n"
+"**/\n"
+"\n"
+"#include \"ficl.h\"\n"
+"\n"
+"\n",
+ cleverTime);
+
+ uncompressedSize = dst - uncompressed;
+ ficlLzCompress(uncompressed, uncompressedSize, &compressed, &compressedSize);
+
+ fprintf(f, "static size_t ficlSoftcoreUncompressedSize = %d; /* not including trailing null */\n", uncompressedSize);
+ fprintf(f, "\n");
+ fprintf(f, "#if !FICL_WANT_LZ_SOFTCORE\n");
+ fprintf(f, "\n");
+ fprintf(f, "static char ficlSoftcoreUncompressed[] =\n");
+ fprintDataAsQuotedString(f, uncompressed);
+ fprintf(f, ";\n");
+ fprintf(f, "\n");
+ fprintf(f, "#else /* !FICL_WANT_LZ_SOFTCORE */\n");
+ fprintf(f, "\n");
+ fprintf(f, "static unsigned char ficlSoftcoreCompressed[%d] = {\n", compressedSize);
+ fprintDataAsHex(f, compressed, compressedSize);
+ fprintf(f, "\t};\n");
+ fprintf(f, "\n");
+ fprintf(f, "#endif /* !FICL_WANT_LZ_SOFTCORE */\n");
+ fprintf(f,
+"\n"
+"\n"
+"void ficlSystemCompileSoftCore(ficlSystem *system)\n"
+"{\n"
+" ficlVm *vm = system->vmList;\n"
+" int returnValue;\n"
+" ficlCell oldSourceID = vm->sourceId;\n"
+" ficlString s;\n"
+"#if FICL_WANT_LZ_SOFTCORE\n"
+" char *ficlSoftcoreUncompressed = NULL;\n"
+" size_t gotUncompressedSize = 0;\n"
+" returnValue = ficlLzUncompress(ficlSoftcoreCompressed, (unsigned char **)&ficlSoftcoreUncompressed, &gotUncompressedSize);\n"
+" FICL_VM_ASSERT(vm, returnValue == 0);\n"
+" FICL_VM_ASSERT(vm, gotUncompressedSize == ficlSoftcoreUncompressedSize);\n"
+"#endif /* FICL_WANT_LZ_SOFTCORE */\n"
+" vm->sourceId.i = -1;\n"
+" FICL_STRING_SET_POINTER(s, (char *)(ficlSoftcoreUncompressed));\n"
+" FICL_STRING_SET_LENGTH(s, ficlSoftcoreUncompressedSize);\n"
+" returnValue = ficlVmExecuteString(vm, s);\n"
+" vm->sourceId = oldSourceID;\n"
+"#if FICL_WANT_LZ_SOFTCORE\n"
+" free(ficlSoftcoreUncompressed);\n"
+"#endif /* FICL_WANT_LZ_SOFTCORE */\n"
+" FICL_VM_ASSERT(vm, returnValue != FICL_VM_STATUS_ERROR_EXIT);\n"
+" return;\n"
+"}\n"
+"\n"
+"/* end-of-file */\n"
+ );
+ free(uncompressed);
+ free(compressed);
+ }
diff --git a/softwords/marker.fr b/softcore/marker.fr
index 0f2ee5eaf493..440732893fda 100644
--- a/softwords/marker.fr
+++ b/softcore/marker.fr
@@ -1,25 +1,25 @@
-\ ** ficl/softwords/marker.fr
-\ ** Ficl implementation of CORE EXT MARKER
-\ John Sadler, 4 Oct 98
-\ Requires ficl 2.02 FORGET-WID !!
-.( loading MARKER ) cr
-: marker ( "name" -- )
- create
- get-current ,
- get-order dup ,
- 0 ?do , loop
- does>
- 0 set-order \ clear search order
- dup body> >name drop
- here - allot \ reset HERE to my xt-addr
- dup @ ( pfa current-wid )
- dup set-current forget-wid ( pfa )
- cell+ dup @ swap ( count count-addr )
- over cells + swap ( last-wid-addr count )
- 0 ?do
- dup @ dup ( wid-addr wid wid )
- >search forget-wid ( wid-addr )
- cell-
- loop
- drop
-;
+\ ** ficl/softwords/marker.fr
+\ ** Ficl implementation of CORE EXT MARKER
+\ John Sadler, 4 Oct 98
+\ Requires ficl 2.02 FORGET-WID !!
+.( loading MARKER ) cr
+: marker ( "name" -- )
+ create
+ get-current ,
+ get-order dup ,
+ 0 ?do , loop
+ does>
+ 0 set-order \ clear search order
+ dup body> >name drop
+ here - allot \ reset HERE to my xt-addr
+ dup @ ( pfa current-wid )
+ dup set-current forget-wid ( pfa )
+ cell+ dup @ swap ( count count-addr )
+ over cells + swap ( last-wid-addr count )
+ 0 ?do
+ dup @ dup ( wid-addr wid wid )
+ >search forget-wid ( wid-addr )
+ cell-
+ loop
+ drop
+;
diff --git a/softwords/oo.fr b/softcore/oo.fr
index 31ab7e3d816d..fcb801d7de26 100644
--- a/softwords/oo.fr
+++ b/softcore/oo.fr
@@ -1,693 +1,700 @@
-\ #if FICL_WANT_OOP
-\ ** ficl/softwords/oo.fr
-\ ** F I C L O - O E X T E N S I O N S
-\ ** john sadler aug 1998
-
-.( loading ficl O-O extensions ) cr
-17 ficl-vocabulary oop
-also oop definitions
-
-\ Design goals:
-\ 0. Traditional OOP: late binding by default for safety.
-\ Early binding if you ask for it.
-\ 1. Single inheritance
-\ 2. Object aggregation (has-a relationship)
-\ 3. Support objects in the dictionary and as proxies for
-\ existing structures (by reference):
-\ *** A ficl object can wrap a C struct ***
-\ 4. Separate name-spaces for methods - methods are
-\ only visible in the context of a class / object
-\ 5. Methods can be overridden, and subclasses can add methods.
-\ No limit on number of methods.
-
-\ General info:
-\ Classes are objects, too: all classes are instances of METACLASS
-\ All classes are derived (by convention) from OBJECT. This
-\ base class provides a default initializer and superclass
-\ access method
-
-\ A ficl object binds instance storage (payload) to a class.
-\ object ( -- instance class )
-\ All objects push their payload address and class address when
-\ 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
-\ of objects created by the class. A class is an object.
-\ The NEW method creates and initializes an instance of a class.
-\ Classes have this footprint:
-\ cell 0: parent class address
-\ cell 1: wordlist ID
-\ cell 2: size of instance's payload
-
-\ Methods expect an object couple ( instance class )
-\ 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, 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 Nov 2001 - metaclass debug method now finds only metaclass methods
-\
-\ Planned: 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 !
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** 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...
-\
-
-\ 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
-
-
-
-: (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
-\ 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 }
- class name (lookup-method) ( 0 | xt 1 | xt -1 )
- 0= if
- name type ." not found in "
- class body> >name type
- cr abort
- endif
-;
-
-: find-method-xt \ name ( class -- class xt )
- parse-word lookup-method
-;
-
-: catch-method ( instance class c-addr u -- <method-signature> exc-flag )
- lookup-method catch
-;
-
-: exec-method ( instance class c-addr u -- <method-signature> )
- lookup-method execute
-;
-
-\ Method lookup operator takes a class-addr and instance-addr
-\ and executes the method from the class's wordlist if
-\ interpreting. If compiling, bind late.
-\
-: --> ( instance class -- ??? )
- state @ 0= if
- find-method-xt execute
- else
- parse-method postpone exec-method
- endif
-; immediate
-
-\ Method lookup with CATCH in case of exceptions
-: c-> ( instance class -- ?? exc-flag )
- state @ 0= if
- find-method-xt catch
- else
- parse-method postpone catch-method
- endif
-; immediate
-
-\ 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 ;
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** E A R L Y B I N D I N G
-\ Early binding operator compiles code to execute a method
-\ given its class at compile time. Classes are immediate,
-\ so they leave their cell-pair on the stack when compiling.
-\ Example:
-\ : get-wid metaclass => .wid @ ;
-\ Usage
-\ my-class get-wid ( -- wid-of-my-class )
-\
-1 ficl-named-wordlist instance-vars
-instance-vars dup >search ficl-set-current
-
-: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
- drop find-method-xt compile, drop
-; immediate compile-only
-
-: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
- current-class @ dup postpone =>
-; immediate compile-only
-
-\ Problem: my=[ assumes that each method except the last is am obj: member
-\ which contains its class as the first field of its parameter area. The code
-\ detects non-obect members and assumes the class does not change in this case.
-\ This handles methods like index, prev, and next correctly, but does not deal
-\ correctly with CLASS.
-: my=[ \ same as my=> , but binds a chain of methods
- current-class @
- begin
- parse-word 2dup ( class c-addr u c-addr u )
- s" ]" compare while ( class c-addr u )
- lookup-method ( class xt )
- dup compile, ( class xt )
- dup ?object if \ If object member, get new class. Otherwise assume same class
- nip >body cell+ @ ( new-class )
- else
- drop ( class )
- endif
- repeat 2drop drop
-; immediate compile-only
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** I N S T A N C E V A R I A B L E S
-\ Instance variables (IV) are represented by words in the class's
-\ private wordlist. Each IV word contains the offset
-\ of the IV it represents, and runs code to add that offset
-\ to the base address of an instance when executed.
-\ The metaclass SUB method, defined below, leaves the address
-\ of the new class's offset field and its initial size on the
-\ stack for these words to update. When a class definition is
-\ complete, END-CLASS saves the final size in the class's size
-\ field, and restores the search order and compile wordlist to
-\ prior state. Note that these words are hidden in their own
-\ wordlist to prevent accidental use outside a SUB END-CLASS pair.
-\
-: do-instance-var
- does> ( instance class addr[offset] -- addr[field] )
- nip @ +
-;
-
-: addr-units: ( offset size "name" -- offset' )
- create over , +
- do-instance-var
-;
-
-: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
- chars addr-units: ;
-
-: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
- 1 chars: ;
-
-: cells: ( offset nCells "name" -- offset' )
- cells >r aligned r> addr-units:
-;
-
-: cell: ( offset nCells "name" -- offset' )
- 1 cells: ;
-
-\ Aggregate an object into the class...
-\ Needs the class of the instance to create
-\ Example: object obj: m_obj
-\
-: do-aggregate
- objectify
- does> ( instance class pfa -- a-instance a-class )
- 2@ ( inst class a-class a-offset )
- 2swap drop ( a-class a-offset inst )
- + swap ( a-inst a-class )
-;
-
-: obj: { offset class meta -- offset' } \ "name"
- create offset , class ,
- class meta --> get-size offset +
- do-aggregate
-;
-
-\ Aggregate an array of objects into a class
-\ Usage example:
-\ 3 my-class array: my-array
-\ Makes an instance variable array of 3 instances of my-class
-\ named my-array.
-\
-: array: ( offset n class meta "name" -- offset' )
- locals| meta class nobjs offset |
- create offset , class ,
- class meta --> get-size nobjs * offset +
- do-aggregate
-;
-
-\ Aggregate a pointer to an object: REF is a member variable
-\ whose class is set at compile time. This is useful for wrapping
-\ data structures in C, where there is only a pointer and the type
-\ it refers to is known. If you want polymorphism, see c_ref
-\ in classes.fr. REF is only useful for pre-initialized structures,
-\ since there's no supported way to set one.
-: ref: ( offset class meta "name" -- offset' )
- locals| meta class offset |
- create offset , class ,
- offset cell+
- does> ( inst class pfa -- ptr-inst ptr-class )
- 2@ ( inst class ptr-class ptr-offset )
- 2swap drop + @ swap
-;
-
-\ #if FICL_WANT_VCALL
-\ vcall extensions contributed by Guy Carver
-: vcall: ( paramcnt "name" -- )
- current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
- create , , \ ( paramcnt index -- )
- does> \ ( inst class pfa -- ptr-inst ptr-class )
- nip 2@ vcall \ ( params offset inst class offset -- )
-;
-
-: vcallr: 0x80000000 or vcall: ; \ Call with return address desired.
-
-\ #if FICL_WANT_FLOAT
-: vcallf: \ ( paramcnt -<name>- f: r )
- 0x80000000 or
- current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
- create , , \ ( paramcnt index -- )
- does> \ ( inst class pfa -- ptr-inst ptr-class )
- nip 2@ vcall f> \ ( params offset inst class offset -- f: r )
-;
-\ #endif /* FLOAT */
-\ #endif /* VCALL */
-
-\ END-CLASS terminates construction of a class by storing
-\ the size of its instance variables in the class's size field
-\ ( -- old-wid addr[size] 0 )
-\
-: end-class ( old-wid addr[size] size -- )
- swap ! set-current
- search> drop \ pop struct builder wordlist
-;
-
-\ See resume-class (a metaclass method) below for usage
-\ This is equivalent to end-class for now, but that will change
-\ when we support vtable bindings.
-: suspend-class ( old-wid addr[size] size -- ) end-class ;
-
-set-current previous
-\ E N D I N S T A N C E V A R I A B L E S
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ D O - D O - I N S T A N C E
-\ Makes a class method that contains the code for an
-\ instance of the class. This word gets compiled into
-\ the wordlist of every class by the SUB method.
-\ PRECONDITION: current-class contains the class address
-\ why use a state variable instead of the stack?
-\ >> Stack state is not well-defined during compilation (there are
-\ >> control structure match codes on the stack, of undefined size
-\ >> easiest way around this is use of this thread-local variable
-\
-: do-do-instance ( -- )
- s" : .do-instance does> [ current-class @ ] literal ;"
- evaluate
-;
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** M E T A C L A S S
-\ Every class is an instance of metaclass. This lets
-\ classes have methods that are different from those
-\ of their instances.
-\ Classes are IMMEDIATE to make early binding simpler
-\ See above...
-\
-:noname
- wordlist
- create
- immediate
- 0 , \ NULL parent class
- dup , \ wid
-\ #if FICL_WANT_VCALL
- 4 cells , \ instance size
-\ #else
- 3 cells , \ instance size
-\ #endif
- ficl-set-current
- does> dup
-; execute metaclass
-\ now brand OBJECT's wordlist (so that ORDER can display it by name)
-metaclass drop cell+ @ brand-wordlist
-
-metaclass drop current-class !
-do-do-instance
-
-\
-\ C L A S S M E T H O D S
-\
-instance-vars >search
-
-create .super ( class metaclass -- parent-class )
- 0 cells , do-instance-var
-
-create .wid ( class metaclass -- wid ) \ return wid of class
- 1 cells , do-instance-var
-
-\ #if FICL_WANT_VCALL
-create .vtCount \ Number of VTABLE methods, if any
- 2 cells , do-instance-var
-
-create .size ( class metaclass -- size ) \ return class's payload size
- 3 cells , do-instance-var
-\ #else
-create .size ( class metaclass -- size ) \ return class's payload size
- 2 cells , do-instance-var
-\ #endif
-
-: get-size metaclass => .size @ ;
-: get-wid metaclass => .wid @ ;
-: get-super metaclass => .super @ ;
-\ #if FICL_WANT_VCALL
-: get-vtCount metaclass => .vtCount @ ;
-: get-vtAdd metaclass => .vtCount ;
-\ #endif
-
-\ create an uninitialized instance of a class, leaving
-\ the address of the new instance and its class
-\
-: instance ( class metaclass "name" -- instance class )
- locals| meta parent |
- create
- here parent --> .do-instance \ ( inst class )
- parent meta metaclass => get-size
- allot \ allocate payload space
-;
-
-\ create an uninitialized array
-: array ( n class metaclass "name" -- n instance class )
- locals| meta parent nobj |
- create nobj
- here parent --> .do-instance \ ( nobj inst class )
- parent meta metaclass => get-size
- nobj * allot \ allocate payload space
-;
-
-\ create an initialized instance
-\
-: new \ ( class metaclass "name" -- )
- metaclass => instance --> init
-;
-
-\ create an initialized array of instances
-: new-array ( n class metaclass "name" -- )
- metaclass => array
- --> array-init
-;
-
-\ Create an anonymous initialized instance from the heap
-: alloc \ ( class metaclass -- instance class )
- locals| meta class |
- class meta metaclass => get-size allocate ( -- addr fail-flag )
- abort" allocate failed " ( -- addr )
- class 2dup --> init
-;
-
-\ Create an anonymous array of initialized instances from the heap
-: alloc-array \ ( n class metaclass -- instance class )
- locals| meta class nobj |
- class meta metaclass => get-size
- nobj * allocate ( -- addr fail-flag )
- abort" allocate failed " ( -- addr )
- nobj over class --> array-init
- class
-;
-
-\ Create an anonymous initialized instance from the dictionary
-: allot { 2:this -- 2:instance }
- here ( instance-address )
- this my=> get-size allot
- this drop 2dup --> init
-;
-
-\ Create an anonymous array of initialized instances from the dictionary
-: allot-array { nobj 2:this -- 2:instance }
- here ( instance-address )
- this my=> get-size nobj * allot
- this drop 2dup ( 2instance 2instance )
- nobj -rot --> array-init
-;
-
-\ create a proxy object with initialized payload address given
-: ref ( instance-addr class metaclass "name" -- )
- drop create , ,
- does> 2@
-;
-
-\ suspend-class and resume-class help to build mutually referent classes.
-\ Example:
-\ object subclass c-akbar
-\ suspend-class ( put akbar on hold while we define jeff )
-\ object subclass c-jeff
-\ c-akbar ref: .akbar
-\ ( and whatever else comprises this class )
-\ end-class ( done with c-jeff )
-\ c-akbar --> resume-class
-\ c-jeff ref: .jeff
-\ ( and whatever else goes in c-akbar )
-\ end-class ( done with c-akbar )
-\
-: resume-class { 2:this -- old-wid addr[size] size }
- this --> .wid @ ficl-set-current ( old-wid )
- this --> .size dup @ ( old-wid addr[size] size )
- instance-vars >search
-;
-
-\ create a subclass
-\ This method leaves the stack and search order ready for instance variable
-\ building. Pushes the instance-vars wordlist onto the search order,
-\ and sets the compilation wordlist to be the private wordlist of the
-\ new class. The class's wordlist is deliberately NOT in the search order -
-\ to prevent methods from getting used with wrong data.
-\ Postcondition: leaves the address of the new class in current-class
-: sub ( class metaclass "name" -- old-wid addr[size] size )
- wordlist
- locals| wid meta parent |
- parent meta metaclass => get-wid
- wid wid-set-super \ set superclass
- create immediate \ get the subclass name
- wid brand-wordlist \ label the subclass wordlist
- here current-class ! \ prep for do-do-instance
- parent , \ save parent class
- wid , \ save wid
-\ #if FICL_WANT_VCALL
- parent meta --> get-vtCount ,
-\ #endif
- here parent meta --> get-size dup , ( addr[size] size )
- metaclass => .do-instance
- wid ficl-set-current -rot
- do-do-instance
- instance-vars >search \ push struct builder wordlist
-;
-
-\ OFFSET-OF returns the offset of an instance variable
-\ from the instance base address. If the next token is not
-\ the name of in instance variable method, you get garbage
-\ results -- there is no way at present to check for this error.
-: offset-of ( class metaclass "name" -- offset )
- drop find-method-xt nip >body @ ;
-
-\ ID returns the string name cell-pair of its class
-: id ( class metaclass -- c-addr u )
- drop body> >name ;
-
-\ list methods of the class
-: methods \ ( class meta -- )
- locals| meta class |
- begin
- class body> >name type ." methods:" cr
- class meta --> get-wid >search words cr previous
- class meta metaclass => get-super
- dup to class
- 0= until cr
-;
-
-\ list class's ancestors
-: pedigree ( class meta -- )
- locals| meta class |
- begin
- class body> >name type space
- class meta metaclass => get-super
- dup to class
- 0= until cr
-;
-
-\ decompile an instance method
-: see ( class meta -- )
- metaclass => get-wid >search see previous ;
-
-\ debug a method of metaclass
-\ Eg: my-class --> debug my-method
-: debug ( class meta -- )
- find-method-xt debug-xt ;
-
-previous set-current
-\ E N D M E T A C L A S S
-
-\ ** META is a nickname for the address of METACLASS...
-metaclass drop
-constant meta
-
-\ ** SUBCLASS is a nickname for a class's SUB method...
-\ Subclass compilation ends when you invoke end-class
-\ This method is late bound for safety...
-: subclass --> sub ;
-
-\ #if FICL_WANT_VCALL
-\ VTABLE Support extensions (Guy Carver)
-\ object --> sub mine hasvtable
-: hasvtable 4 + ; immediate
-\ #endif
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** O B J E C T
-\ Root of all classes
-:noname
- wordlist
- create immediate
- 0 , \ NULL parent class
- dup , \ wid
- 0 , \ instance size
- ficl-set-current
- does> meta
-; execute object
-\ now brand OBJECT's wordlist (so that ORDER can display it by name)
-object drop cell+ @ brand-wordlist
-
-object drop current-class !
-do-do-instance
-instance-vars >search
-
-\ O B J E C T M E T H O D S
-\ Convert instance cell-pair to class cell-pair
-\ Useful for binding class methods from an instance
-: class ( instance class -- class metaclass )
- nip meta ;
-
-\ default INIT method zero fills an instance
-: init ( instance class -- )
- meta
- metaclass => get-size ( inst size )
- erase ;
-
-\ Apply INIT to an array of NOBJ objects...
-\
-: array-init ( nobj inst class -- )
- 0 dup locals| &init &next class inst |
- \
- \ bind methods outside the loop to save time
- \
- class s" init" lookup-method to &init
- s" next" lookup-method to &next
- drop
- 0 ?do
- inst class 2dup
- &init execute
- &next execute drop to inst
- loop
-;
-
-\ free storage allocated to a heap instance by alloc or alloc-array
-\ NOTE: not protected against errors like FREEing something that's
-\ really in the dictionary.
-: free \ ( instance class -- )
- drop free
- abort" free failed "
-;
-
-\ Instance aliases for common class methods
-\ Upcast to parent class
-: super ( instance class -- instance parent-class )
- meta metaclass => get-super ;
-
-: pedigree ( instance class -- )
- object => class
- metaclass => pedigree ;
-
-: size ( instance class -- sizeof-instance )
- object => class
- metaclass => get-size ;
-
-: methods ( instance class -- )
- object => class
- metaclass => methods ;
-
-\ Array indexing methods...
-\ Usage examples:
-\ 10 object-array --> index
-\ obj --> next
-\
-: index ( n instance class -- instance[n] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size * ( n*size )
- inst + class ;
-
-: next ( instance[n] class -- instance[n+1] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size
- inst +
- class ;
-
-: prev ( instance[n] class -- instance[n-1] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size
- inst swap -
- class ;
-
-: debug ( 2this -- ?? )
- find-method-xt debug-xt ;
-
-previous set-current
-\ E N D O B J E C T
-
-\ reset to default search order
-only definitions
-
-\ redefine oop in default search order to put OOP words in the search order and make them
-\ the compiling wordlist...
-
-: oo only also oop definitions ;
-
-\ #endif
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** ficl/softwords/oo.fr
+\ ** F I C L O - O E X T E N S I O N S
+\ ** john sadler aug 1998
+
+.( loading ficl O-O extensions ) cr
+17 ficl-vocabulary oop
+also oop definitions
+
+\ Design goals:
+\ 0. Traditional OOP: late binding by default for safety.
+\ Early binding if you ask for it.
+\ 1. Single inheritance
+\ 2. Object aggregation (has-a relationship)
+\ 3. Support objects in the dictionary and as proxies for
+\ existing structures (by reference):
+\ *** A ficl object can wrap a C struct ***
+\ 4. Separate name-spaces for methods - methods are
+\ only visible in the context of a class / object
+\ 5. Methods can be overridden, and subclasses can add methods.
+\ No limit on number of methods.
+
+\ General info:
+\ Classes are objects, too: all classes are instances of METACLASS
+\ All classes are derived (by convention) from OBJECT. This
+\ base class provides a default initializer and superclass
+\ access method
+
+\ A ficl object binds instance storage (payload) to a class.
+\ object ( -- instance class )
+\ All objects push their payload address and class address when
+\ 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
+\ of objects created by the class. A class is an object.
+\ The NEW method creates and initializes an instance of a class.
+\ Classes have this footprint:
+\ cell 0: parent class address
+\ cell 1: wordlist ID
+\ cell 2: size of instance's payload
+
+\ Methods expect an object couple ( instance class )
+\ 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, 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 Nov 2001 - metaclass debug method now finds only metaclass methods
+\
+\ Planned: 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 !
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** 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...
+\
+
+\ 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
+
+
+
+: (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
+\ 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 }
+ class name (lookup-method) ( 0 | xt 1 | xt -1 )
+ 0= if
+ name type ." not found in "
+ class body> >name type
+ cr abort
+ endif
+;
+
+: find-method-xt \ name ( class -- class xt )
+ parse-word lookup-method
+;
+
+: catch-method ( instance class c-addr u -- <method-signature> exc-flag )
+ lookup-method catch
+;
+
+: exec-method ( instance class c-addr u -- <method-signature> )
+ lookup-method execute
+;
+
+\ Method lookup operator takes a class-addr and instance-addr
+\ and executes the method from the class's wordlist if
+\ interpreting. If compiling, bind late.
+\
+: --> ( instance class -- ??? )
+ state @ 0= if
+ find-method-xt execute
+ else
+ parse-method postpone exec-method
+ endif
+; immediate
+
+\ Method lookup with CATCH in case of exceptions
+: c-> ( instance class -- ?? exc-flag )
+ state @ 0= if
+ find-method-xt catch
+ else
+ parse-method postpone catch-method
+ endif
+; immediate
+
+\ 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 ;
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** E A R L Y B I N D I N G
+\ Early binding operator compiles code to execute a method
+\ given its class at compile time. Classes are immediate,
+\ so they leave their cell-pair on the stack when compiling.
+\ Example:
+\ : get-wid metaclass => .wid @ ;
+\ Usage
+\ my-class get-wid ( -- wid-of-my-class )
+\
+1 ficl-named-wordlist instance-vars
+instance-vars dup >search ficl-set-current
+
+: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
+ drop find-method-xt compile, drop
+; immediate compile-only
+
+: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
+ current-class @ dup postpone =>
+; immediate compile-only
+
+\ Problem: my=[ assumes that each method except the last is an obj: member
+\ which contains its class as the first field of its parameter area. The code
+\ detects non-obect members and assumes the class does not change in this case.
+\ This handles methods like index, prev, and next correctly, but does not deal
+\ correctly with CLASS.
+: my=[ \ same as my=> , but binds a chain of methods
+ current-class @
+ begin
+ parse-word 2dup ( class c-addr u c-addr u )
+ s" ]" compare while ( class c-addr u )
+ lookup-method ( class xt )
+ dup compile, ( class xt )
+ dup ?object if \ If object member, get new class. Otherwise assume same class
+ nip >body cell+ @ ( new-class )
+ else
+ drop ( class )
+ endif
+ repeat 2drop drop
+; immediate compile-only
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** I N S T A N C E V A R I A B L E S
+\ Instance variables (IV) are represented by words in the class's
+\ private wordlist. Each IV word contains the offset
+\ of the IV it represents, and runs code to add that offset
+\ to the base address of an instance when executed.
+\ The metaclass SUB method, defined below, leaves the address
+\ of the new class's offset field and its initial size on the
+\ stack for these words to update. When a class definition is
+\ complete, END-CLASS saves the final size in the class's size
+\ field, and restores the search order and compile wordlist to
+\ prior state. Note that these words are hidden in their own
+\ wordlist to prevent accidental use outside a SUB END-CLASS pair.
+\
+: do-instance-var
+ does> ( instance class addr[offset] -- addr[field] )
+ nip @ +
+;
+
+: addr-units: ( offset size "name" -- offset' )
+ create over , +
+ do-instance-var
+;
+
+: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
+ chars addr-units: ;
+
+: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
+ 1 chars: ;
+
+: cells: ( offset nCells "name" -- offset' )
+ cells >r aligned r> addr-units:
+;
+
+: cell: ( offset nCells "name" -- offset' )
+ 1 cells: ;
+
+\ Aggregate an object into the class...
+\ Needs the class of the instance to create
+\ Example: object obj: m_obj
+\
+: do-aggregate
+ objectify
+ does> ( instance class pfa -- a-instance a-class )
+ 2@ ( inst class a-class a-offset )
+ 2swap drop ( a-class a-offset inst )
+ + swap ( a-inst a-class )
+;
+
+: obj: { offset class meta -- offset' } \ "name"
+ create offset , class ,
+ class meta --> get-size offset +
+ do-aggregate
+;
+
+\ Aggregate an array of objects into a class
+\ Usage example:
+\ 3 my-class array: my-array
+\ Makes an instance variable array of 3 instances of my-class
+\ named my-array.
+\
+: array: ( offset n class meta "name" -- offset' )
+ locals| meta class nobjs offset |
+ create offset , class ,
+ class meta --> get-size nobjs * offset +
+ do-aggregate
+;
+
+\ Aggregate a pointer to an object: REF is a member variable
+\ whose class is set at compile time. This is useful for wrapping
+\ data structures in C, where there is only a pointer and the type
+\ it refers to is known. If you want polymorphism, see c_ref
+\ in classes.fr. REF is only useful for pre-initialized structures,
+\ since there's no supported way to set one.
+: ref: ( offset class meta "name" -- offset' )
+ locals| meta class offset |
+ create offset , class ,
+ offset cell+
+ does> ( inst class pfa -- ptr-inst ptr-class )
+ 2@ ( inst class ptr-class ptr-offset )
+ 2swap drop + @ swap
+;
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+\ vcall extensions contributed by Guy Carver
+: vcall: ( paramcnt "name" -- )
+ current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
+ create , , \ ( paramcnt index -- )
+ does> \ ( inst class pfa -- ptr-inst ptr-class )
+ nip 2@ vcall \ ( params offset inst class offset -- )
+;
+
+: vcallr: 0x80000000 or vcall: ; \ Call with return address desired.
+
+S" FICL_WANT_FLOAT" ENVIRONMENT? drop [if]
+: vcallf: \ ( paramcnt -<name>- f: r )
+ 0x80000000 or
+ current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
+ create , , \ ( paramcnt index -- )
+ does> \ ( inst class pfa -- ptr-inst ptr-class )
+ nip 2@ vcall f> \ ( params offset inst class offset -- f: r )
+;
+
+[endif] \ FICL_WANT_FLOAT
+[endif] \ FICL_WANT_VCALL
+
+\ END-CLASS terminates construction of a class by storing
+\ the size of its instance variables in the class's size field
+\ ( -- old-wid addr[size] 0 )
+\
+: end-class ( old-wid addr[size] size -- )
+ swap ! set-current
+ search> drop \ pop struct builder wordlist
+;
+
+\ See resume-class (a metaclass method) below for usage
+\ This is equivalent to end-class for now, but that will change
+\ when we support vtable bindings.
+: suspend-class ( old-wid addr[size] size -- ) end-class ;
+
+set-current previous
+\ E N D I N S T A N C E V A R I A B L E S
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ D O - D O - I N S T A N C E
+\ Makes a class method that contains the code for an
+\ instance of the class. This word gets compiled into
+\ the wordlist of every class by the SUB method.
+\ PRECONDITION: current-class contains the class address
+\ why use a state variable instead of the stack?
+\ >> Stack state is not well-defined during compilation (there are
+\ >> control structure match codes on the stack, of undefined size
+\ >> easiest way around this is use of this thread-local variable
+\
+: do-do-instance ( -- )
+ s" : .do-instance does> [ current-class @ ] literal ;"
+ evaluate
+;
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** M E T A C L A S S
+\ Every class is an instance of metaclass. This lets
+\ classes have methods that are different from those
+\ of their instances.
+\ Classes are IMMEDIATE to make early binding simpler
+\ See above...
+\
+:noname
+ wordlist
+ create
+ immediate
+ 0 , \ NULL parent class
+ dup , \ wid
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ 4 cells , \ instance size
+[else]
+ 3 cells , \ instance size
+[endif]
+ ficl-set-current
+ does> dup
+; execute metaclass
+\ now brand OBJECT's wordlist (so that ORDER can display it by name)
+metaclass drop cell+ @ brand-wordlist
+
+metaclass drop current-class !
+do-do-instance
+
+\
+\ C L A S S M E T H O D S
+\
+instance-vars >search
+
+create .super ( class metaclass -- parent-class )
+ 0 cells , do-instance-var
+
+create .wid ( class metaclass -- wid ) \ return wid of class
+ 1 cells , do-instance-var
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+create .vtCount \ Number of VTABLE methods, if any
+ 2 cells , do-instance-var
+
+create .size ( class metaclass -- size ) \ return class's payload size
+ 3 cells , do-instance-var
+
+[else]
+
+create .size ( class metaclass -- size ) \ return class's payload size
+ 2 cells , do-instance-var
+
+[endif]
+
+: get-size metaclass => .size @ ;
+: get-wid metaclass => .wid @ ;
+: get-super metaclass => .super @ ;
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+: get-vtCount metaclass => .vtCount @ ;
+: get-vtAdd metaclass => .vtCount ;
+[endif]
+
+\ create an uninitialized instance of a class, leaving
+\ the address of the new instance and its class
+\
+: instance ( class metaclass "name" -- instance class )
+ locals| meta parent |
+ create
+ here parent --> .do-instance \ ( inst class )
+ parent meta metaclass => get-size
+ allot \ allocate payload space
+;
+
+\ create an uninitialized array
+: array ( n class metaclass "name" -- n instance class )
+ locals| meta parent nobj |
+ create nobj
+ here parent --> .do-instance \ ( nobj inst class )
+ parent meta metaclass => get-size
+ nobj * allot \ allocate payload space
+;
+
+\ create an initialized instance
+\
+: new \ ( class metaclass "name" -- )
+ metaclass => instance --> init
+;
+
+\ create an initialized array of instances
+: new-array ( n class metaclass "name" -- )
+ metaclass => array
+ --> array-init
+;
+
+\ Create an anonymous initialized instance from the heap
+: alloc \ ( class metaclass -- instance class )
+ locals| meta class |
+ class meta metaclass => get-size allocate ( -- addr fail-flag )
+ abort" allocate failed " ( -- addr )
+ class 2dup --> init
+;
+
+\ Create an anonymous array of initialized instances from the heap
+: alloc-array \ ( n class metaclass -- instance class )
+ locals| meta class nobj |
+ class meta metaclass => get-size
+ nobj * allocate ( -- addr fail-flag )
+ abort" allocate failed " ( -- addr )
+ nobj over class --> array-init
+ class
+;
+
+\ Create an anonymous initialized instance from the dictionary
+: allot { 2:this -- 2:instance }
+ here ( instance-address )
+ this my=> get-size allot
+ this drop 2dup --> init
+;
+
+\ Create an anonymous array of initialized instances from the dictionary
+: allot-array { nobj 2:this -- 2:instance }
+ here ( instance-address )
+ this my=> get-size nobj * allot
+ this drop 2dup ( 2instance 2instance )
+ nobj -rot --> array-init
+;
+
+\ create a proxy object with initialized payload address given
+: ref ( instance-addr class metaclass "name" -- )
+ drop create , ,
+ does> 2@
+;
+
+\ suspend-class and resume-class help to build mutually referent classes.
+\ Example:
+\ object subclass c-akbar
+\ suspend-class ( put akbar on hold while we define jeff )
+\ object subclass c-jeff
+\ c-akbar ref: .akbar
+\ ( and whatever else comprises this class )
+\ end-class ( done with c-jeff )
+\ c-akbar --> resume-class
+\ c-jeff ref: .jeff
+\ ( and whatever else goes in c-akbar )
+\ end-class ( done with c-akbar )
+\
+: resume-class { 2:this -- old-wid addr[size] size }
+ this --> .wid @ ficl-set-current ( old-wid )
+ this --> .size dup @ ( old-wid addr[size] size )
+ instance-vars >search
+;
+
+\ create a subclass
+\ This method leaves the stack and search order ready for instance variable
+\ building. Pushes the instance-vars wordlist onto the search order,
+\ and sets the compilation wordlist to be the private wordlist of the
+\ new class. The class's wordlist is deliberately NOT in the search order -
+\ to prevent methods from getting used with wrong data.
+\ Postcondition: leaves the address of the new class in current-class
+: sub ( class metaclass "name" -- old-wid addr[size] size )
+ wordlist
+ locals| wid meta parent |
+ parent meta metaclass => get-wid
+ wid wid-set-super \ set superclass
+ create immediate \ get the subclass name
+ wid brand-wordlist \ label the subclass wordlist
+ here current-class ! \ prep for do-do-instance
+ parent , \ save parent class
+ wid , \ save wid
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ parent meta --> get-vtCount ,
+[endif]
+ here parent meta --> get-size dup , ( addr[size] size )
+ metaclass => .do-instance
+ wid ficl-set-current -rot
+ do-do-instance
+ instance-vars >search \ push struct builder wordlist
+;
+
+\ OFFSET-OF returns the offset of an instance variable
+\ from the instance base address. If the next token is not
+\ the name of in instance variable method, you get garbage
+\ results -- there is no way at present to check for this error.
+: offset-of ( class metaclass "name" -- offset )
+ drop find-method-xt nip >body @ ;
+
+\ ID returns the string name cell-pair of its class
+: id ( class metaclass -- c-addr u )
+ drop body> >name ;
+
+\ list methods of the class
+: methods \ ( class meta -- )
+ locals| meta class |
+ begin
+ class body> >name type ." methods:" cr
+ class meta --> get-wid >search words cr previous
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
+;
+
+\ list class's ancestors
+: pedigree ( class meta -- )
+ locals| meta class |
+ begin
+ class body> >name type space
+ class meta metaclass => get-super
+ dup to class
+ 0= until cr
+;
+
+\ decompile an instance method
+: see ( class meta -- )
+ metaclass => get-wid >search see previous ;
+
+\ debug a method of metaclass
+\ Eg: my-class --> debug my-method
+: debug ( class meta -- )
+ find-method-xt debug-xt ;
+
+previous set-current
+\ E N D M E T A C L A S S
+
+\ ** META is a nickname for the address of METACLASS...
+metaclass drop
+constant meta
+
+\ ** SUBCLASS is a nickname for a class's SUB method...
+\ Subclass compilation ends when you invoke end-class
+\ This method is late bound for safety...
+: subclass --> sub ;
+
+S" FICL_WANT_VCALL" ENVIRONMENT? drop [if]
+\ VTABLE Support extensions (Guy Carver)
+\ object --> sub mine hasvtable
+: hasvtable 4 + ; immediate
+[endif]
+
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+\ ** O B J E C T
+\ Root of all classes
+:noname
+ wordlist
+ create immediate
+ 0 , \ NULL parent class
+ dup , \ wid
+ 0 , \ instance size
+[ S" FICL_WANT_VCALL" ENVIRONMENT? drop ] [if]
+ 0 , \ .vtCount
+[endif]
+ ficl-set-current
+ does> meta
+; execute object
+\ now brand OBJECT's wordlist (so that ORDER can display it by name)
+object drop cell+ @ brand-wordlist
+
+object drop current-class !
+do-do-instance
+instance-vars >search
+
+\ O B J E C T M E T H O D S
+\ Convert instance cell-pair to class cell-pair
+\ Useful for binding class methods from an instance
+: class ( instance class -- class metaclass )
+ nip meta ;
+
+\ default INIT method zero fills an instance
+: init ( instance class -- )
+ meta
+ metaclass => get-size ( inst size )
+ erase ;
+
+\ Apply INIT to an array of NOBJ objects...
+\
+: array-init ( nobj inst class -- )
+ 0 dup locals| &init &next class inst |
+ \
+ \ bind methods outside the loop to save time
+ \
+ class s" init" lookup-method to &init
+ s" next" lookup-method to &next
+ drop
+ 0 ?do
+ inst class 2dup
+ &init execute
+ &next execute drop to inst
+ loop
+;
+
+\ free storage allocated to a heap instance by alloc or alloc-array
+\ NOTE: not protected against errors like FREEing something that's
+\ really in the dictionary.
+: free \ ( instance class -- )
+ drop free
+ abort" free failed "
+;
+
+\ Instance aliases for common class methods
+\ Upcast to parent class
+: super ( instance class -- instance parent-class )
+ meta metaclass => get-super ;
+
+: pedigree ( instance class -- )
+ object => class
+ metaclass => pedigree ;
+
+: size ( instance class -- sizeof-instance )
+ object => class
+ metaclass => get-size ;
+
+: methods ( instance class -- )
+ object => class
+ metaclass => methods ;
+
+\ Array indexing methods...
+\ Usage examples:
+\ 10 object-array --> index
+\ obj --> next
+\
+: index ( n instance class -- instance[n] class )
+ locals| class inst |
+ inst class
+ object => class
+ metaclass => get-size * ( n*size )
+ inst + class ;
+
+: next ( instance[n] class -- instance[n+1] class )
+ locals| class inst |
+ inst class
+ object => class
+ metaclass => get-size
+ inst +
+ class ;
+
+: prev ( instance[n] class -- instance[n-1] class )
+ locals| class inst |
+ inst class
+ object => class
+ metaclass => get-size
+ inst swap -
+ class ;
+
+: debug ( 2this -- ?? )
+ find-method-xt debug-xt ;
+
+previous set-current
+\ E N D O B J E C T
+
+\ reset to default search order
+only definitions
+
+\ redefine oop in default search order to put OOP words in the search order and make them
+\ the compiling wordlist...
+
+: oo only also oop definitions ;
+
+[endif]
diff --git a/softwords/prefix.fr b/softcore/prefix.fr
index 7ccd14f0cb14..3c368d66ea75 100644
--- a/softwords/prefix.fr
+++ b/softcore/prefix.fr
@@ -1,57 +1,47 @@
-\ **
-\ ** Prefix words for ficl
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-\ (jws) To make a prefix, simply create a new definition in the <prefixes>
-\ wordlist. start-prefixes and end-prefixes handle the bookkeeping
-
-variable save-current
-
-: start-prefixes get-current save-current ! <prefixes> set-current ;
-: end-prefixes save-current @ set-current ;
-: show-prefixes <prefixes> >search words search> drop ;
-
-\ #if (FICL_EXTENDED_PREFIX)
-
-start-prefixes
-
-\ define " (double-quote) as an alias for s", and make it a prefix
-: " postpone s" ; immediate
-
-
-\ 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
-\ (jws) "//" is precompiled to save aggravation with Perl
-\ : // postpone \ ; immediate
-
-
-\ ** add 0b, 0o, 0d, and 0x as prefixes
-\ ** these temporarily shift the base to 2, 8, 10, and 16 respectively
-\ ** and consume the next number in the input stream, pushing/compiling
-\ ** as normal
-
-\ (jws) __tempbase is precompiled, as are 0x and 0d - see prefix.c
-\
-\ : __tempbase { newbase | oldbase -- }
-\ base @ to oldbase
-\ newbase base !
-\ 0 0 parse-word >number 2drop drop
-\ oldbase base !
-\ ;
-
-: 0b 2 __tempbase ; immediate
-
-: 0o 8 __tempbase ; immediate
-
-\ : 0d 10 __tempbase ; immediate
-\ "0d" add-prefix
-
-\ : 0x 16 __tempbase ; immediate
-\ "0x" add-prefix
-
-end-prefixes
-
-\ #endif
+\ **
+\ ** Prefix words for ficl
+\ ** submitted by Larry Hastings, larry@hastings.org
+\ **
+\ (jws) To make a prefix, simply create a new definition in the <prefixes>
+\ wordlist. start-prefixes and end-prefixes handle the bookkeeping
+
+variable save-current
+
+: start-prefixes get-current save-current ! <prefixes> set-current ;
+: end-prefixes save-current @ set-current ;
+: show-prefixes <prefixes> >search words search> drop ;
+
+start-prefixes
+
+S" FICL_WANT_EXTENDED_PREFIX" ENVIRONMENT? drop [if]
+
+\ define " (double-quote) as an alias for s", and make it a prefix
+: " postpone s" ; immediate
+
+
+\ 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
+: \ postpone \ ; immediate
+: // postpone \ ; immediate
+
+
+\ ** add 0b, 0o, 0d, and 0x as prefixes
+\ ** these temporarily shift the base to 2, 8, 10, and 16 respectively
+\ ** and consume the next number in the input stream, pushing/compiling
+\ ** as normal
+\ **
+\ ** __tempbase is precompiled, see prefix.c
+
+: 0b 2 __tempbase ; immediate
+: 0o 8 __tempbase ; immediate
+
+[endif]
+
+: 0d 10 __tempbase ; immediate
+: 0x 16 __tempbase ; immediate
+
+end-prefixes
+
diff --git a/softwords/softcore.fr b/softcore/softcore.fr
index 14bc065af073..6cce6589a831 100644
--- a/softwords/softcore.fr
+++ b/softcore/softcore.fr
@@ -1,207 +1,152 @@
-\ ** ficl/softwords/softcore.fr
-\ ** FICL soft extensions
-\ ** John Sadler (john_sadler@alum.mit.edu)
-\ ** September, 1998
-
-\ ** Ficl USER variables
-\ ** See words.c for primitive def'n of USER
-.( loading ficl soft extensions ) cr
-\ #if FICL_WANT_USER
-variable nUser 0 nUser !
-: user \ name ( -- )
- nUser dup @ user 1 swap +! ;
-
-\ #endif
-
-\ ** ficl extras
-\ EMPTY cleans the parameter stack
-: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
-\ CELL- undoes CELL+
-: cell- ( addr -- addr ) [ 1 cells ] literal - ;
-: -rot ( a b c -- c a b ) 2 -roll ;
-
-\ ** CORE
-: abs ( x -- x )
- dup 0< if negate endif ;
-decimal 32 constant bl
-
-: space ( -- ) bl emit ;
-
-: spaces ( n -- ) 0 ?do space loop ;
-
-: abort"
- state @ if
- postpone if
- postpone ."
- postpone cr
- -2
- postpone literal
- postpone throw
- postpone endif
- else
- [char] " parse
- rot if
- type
- cr
- -2 throw
- else
- 2drop
- endif
- endif
-; immediate
-
-
-\ ** CORE EXT
-.( loading CORE EXT words ) cr
-0 constant false
-false invert constant true
-: <> = 0= ;
-: 0<> 0= 0= ;
-: compile, , ;
-: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
-: erase ( addr u -- ) 0 fill ;
-variable span
-: expect ( c-addr u1 -- ) accept span ! ;
-\ see marker.fr for MARKER implementation
-: nip ( y x -- x ) swap drop ;
-: tuck ( y x -- x y x) swap over ;
-: within ( test low high -- flag ) over - >r - r> u< ;
-
-
-\ ** LOCAL EXT word set
-\ #if FICL_WANT_LOCALS
-: locals| ( name...name | -- )
- begin
- bl word count
- dup 0= abort" where's the delimiter??"
- over c@
- [char] | - over 1- or
- while
- (local)
- repeat 2drop 0 0 (local)
-; immediate
-
-: local ( name -- ) bl word count (local) ; immediate
-
-: 2local ( name -- ) bl word count (2local) ; immediate
-
-: end-locals ( -- ) 0 0 (local) ; immediate
-
-\ #endif
-
-\ ** TOOLS word set...
-: ? ( addr -- ) @ . ;
-: dump ( addr u -- )
- 0 ?do
- dup c@ . 1+
- i 7 and 7 = if cr endif
- loop drop
-;
-
-\ ** SEARCH+EXT words and ficl helpers
-.( loading SEARCH & SEARCH-EXT words ) cr
-\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
-\ wordlist dup create , brand-wordlist
-\ gets the name of the word made by create and applies it to the wordlist...
-: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
-
-: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
- ficl-wordlist dup create , brand-wordlist does> @ ;
-
-: wordlist ( -- )
- 1 ficl-wordlist ;
-
-\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
-: ficl-set-current ( wid -- old-wid )
- get-current swap set-current ;
-
-\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
-\ When executed, new voc replaces top of search stack
-: do-vocabulary ( -- )
- does> @ search> drop >search ;
-
-: ficl-vocabulary ( nBuckets name -- )
- ficl-named-wordlist do-vocabulary ;
-
-: vocabulary ( name -- )
- 1 ficl-vocabulary ;
-
-\ PREVIOUS drops the search order stack
-: previous ( -- ) search> drop ;
-
-\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
-\ USAGE:
-\ hide
-\ <definitions to hide>
-\ set-current
-\ <words that use hidden defs>
-\ previous ( pop HIDDEN off the search order )
-
-1 ficl-named-wordlist hidden
-: hide hidden dup >search ficl-set-current ;
-
-\ ALSO dups the search stack...
-: also ( -- )
- search> dup >search >search ;
-
-\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
-: forth ( -- )
- search> drop
- forth-wordlist >search ;
-
-\ ONLY sets the search order to a default state
-: only ( -- )
- -1 set-order ;
-
-\ ORDER displays the compile wid and the search order list
-hide
-: list-wid ( wid -- )
- dup wid-get-name ( wid c-addr u )
- ?dup if
- type drop
- else
- drop ." (unnamed wid) " x.
- endif cr
-;
-set-current \ stop hiding words
-
-: order ( -- )
- ." Search:" cr
- get-order 0 ?do 3 spaces list-wid loop cr
- ." Compile: " get-current list-wid cr
-;
-
-: debug ' debug-xt ; immediate
-: 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
-
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+
+\ ** ficl extras
+\ EMPTY cleans the parameter stack
+: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
+\ CELL- undoes CELL+
+: cell- ( addr -- addr ) [ 1 cells ] literal - ;
+: -rot ( a b c -- c a b ) 2 -roll ;
+
+\ ** CORE
+: abs ( x -- x )
+ dup 0< if negate endif ;
+decimal 32 constant bl
+
+: space ( -- ) bl emit ;
+
+: spaces ( n -- ) 0 ?do space loop ;
+
+: abort"
+ state @ if
+ postpone if
+ postpone ."
+ postpone cr
+ -2
+ postpone literal
+ postpone throw
+ postpone endif
+ else
+ [char] " parse
+ rot if
+ type
+ cr
+ -2 throw
+ else
+ 2drop
+ endif
+ endif
+; immediate
+
+
+\ ** CORE EXT
+.( loading CORE EXT words ) cr
+0 constant false
+false invert constant true
+: <> = 0= ;
+: 0<> 0= 0= ;
+: compile, , ;
+: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
+: erase ( addr u -- ) 0 fill ;
+variable span
+: expect ( c-addr u1 -- ) accept span ! ;
+\ see marker.fr for MARKER implementation
+: nip ( y x -- x ) swap drop ;
+: tuck ( y x -- x y x) swap over ;
+: within ( test low high -- flag ) over - >r - r> u< ;
+
+
+
+\ ** TOOLS word set...
+: ? ( addr -- ) @ . ;
+: dump ( addr u -- )
+ 0 ?do
+ dup c@ . 1+
+ i 7 and 7 = if cr endif
+ loop drop
+;
+
+\ ** SEARCH+EXT words and ficl helpers
+.( loading SEARCH & SEARCH-EXT words ) cr
+\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
+\ wordlist dup create , brand-wordlist
+\ gets the name of the word made by create and applies it to the wordlist...
+: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
+
+: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
+ ficl-wordlist dup create , brand-wordlist does> @ ;
+
+: wordlist ( -- )
+ 1 ficl-wordlist ;
+
+\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
+: ficl-set-current ( wid -- old-wid )
+ get-current swap set-current ;
+
+\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
+\ When executed, new voc replaces top of search stack
+: do-vocabulary ( -- )
+ does> @ search> drop >search ;
+
+: ficl-vocabulary ( nBuckets name -- )
+ ficl-named-wordlist do-vocabulary ;
+
+: vocabulary ( name -- )
+ 1 ficl-vocabulary ;
+
+\ PREVIOUS drops the search order stack
+: previous ( -- ) search> drop ;
+
+\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
+\ USAGE:
+\ hide
+\ <definitions to hide>
+\ set-current
+\ <words that use hidden defs>
+\ previous ( pop HIDDEN off the search order )
+
+1 ficl-named-wordlist hidden
+: hide hidden dup >search ficl-set-current ;
+
+\ ALSO dups the search stack...
+: also ( -- )
+ search> dup >search >search ;
+
+\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
+: forth ( -- )
+ search> drop
+ forth-wordlist >search ;
+
+\ ONLY sets the search order to a default state
+: only ( -- )
+ -1 set-order ;
+
+\ ORDER displays the compile wid and the search order list
+hide
+: list-wid ( wid -- )
+ dup wid-get-name ( wid c-addr u )
+ ?dup if
+ type drop
+ else
+ drop ." (unnamed wid) " x.
+ endif cr
+;
+set-current \ stop hiding words
+
+: order ( -- )
+ ." Search:" cr
+ get-order 0 ?do 3 spaces list-wid loop cr
+ ." Compile: " get-current list-wid cr
+;
+
+: debug ' debug-xt ; immediate
+: on-step ." S: " .s-simple cr ;
+
+
+previous \ lose hidden words from search order
+
+\ ** E N D S O F T C O R E . F R
+
diff --git a/softwords/string.fr b/softcore/string.fr
index e7f2c698f2f4..795b8ce38d0a 100644
--- a/softwords/string.fr
+++ b/softcore/string.fr
@@ -1,148 +1,149 @@
-\ #if (FICL_WANT_OOP)
-\ ** ficl/softwords/string.fr
-\ A useful dynamic string class
-\ John Sadler 14 Sep 1998
-\
-\ ** C - S T R I N G
-\ counted string, buffer sized dynamically
-\ Creation example:
-\ c-string --> new str
-\ s" arf arf!!" str --> set
-\ s" woof woof woof " str --> cat
-\ str --> type cr
-\
-
-.( loading ficl string class ) cr
-also oop definitions
-
-object subclass c-string
- c-cell obj: .count
- c-cell obj: .buflen
- c-ptr obj: .buf
- 32 constant min-buf
-
- : get-count ( 2:this -- count ) my=[ .count get ] ;
- : set-count ( count 2:this -- ) my=[ .count set ] ;
-
- : ?empty ( 2:this -- flag ) --> get-count 0= ;
-
- : get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
- : set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
-
- : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;
- : set-buf { ptr len 2:this -- }
- ptr this my=[ .buf set-ptr ]
- len this my=> set-buflen
- ;
-
- \ set buffer to null and buflen to zero
- : clr-buf ( 2:this -- )
- 0 0 2over my=> set-buf
- 0 -rot my=> set-count
- ;
-
- \ free the buffer if there is one, set buf pointer to null
- : free-buf { 2:this -- }
- this my=> get-buf
- ?dup if
- free
- abort" c-string free failed"
- this my=> clr-buf
- endif
- ;
-
- \ guarantee buffer is large enough to hold size chars
- : size-buf { size 2:this -- }
- size 0< abort" need positive size for size-buf"
- size 0= if
- this --> free-buf exit
- endif
-
- \ force buflen to be a positive multiple of min-buf chars
- my=> min-buf size over / 1+ * chars to size
-
- \ if buffer is null, allocate one, else resize it
- this --> get-buflen 0=
- if
- size allocate
- abort" out of memory"
- size this --> set-buf
- size this --> set-buflen
- exit
- endif
-
- size this --> get-buflen > if
- this --> get-buf size resize
- abort" out of memory"
- size this --> set-buf
- endif
- ;
-
- : set { c-addr u 2:this -- }
- u this --> size-buf
- u this --> set-count
- c-addr this --> get-buf u move
- ;
-
- : get { 2:this -- c-addr u }
- this --> get-buf
- this --> get-count
- ;
-
- \ append string to existing one
- : cat { c-addr u 2:this -- }
- this --> get-count u + dup >r
- this --> size-buf
- c-addr this --> get-buf this --> get-count + u move
- r> this --> set-count
- ;
-
- : type { 2:this -- }
- this --> ?empty if ." (empty) " exit endif
- this --> .buf --> get-ptr
- this --> .count --> get
- type
- ;
-
- : compare ( 2string 2:this -- n )
- --> get
- 2swap
- --> get
- 2swap compare
- ;
-
- : hashcode ( 2:this -- hashcode )
- --> get hash
- ;
-
- \ destructor method (overrides object --> free)
- : free ( 2:this -- ) 2dup --> free-buf object => free ;
-
-end-class
-
-c-string subclass c-hashstring
- c-2byte obj: .hashcode
-
- : set-hashcode { 2:this -- }
- this --> super --> hashcode
- this --> .hashcode --> set
- ;
-
- : get-hashcode ( 2:this -- hashcode )
- --> .hashcode --> get
- ;
-
- : set ( c-addr u 2:this -- )
- 2swap 2over --> super --> set
- --> set-hashcode
- ;
-
- : cat ( c-addr u 2:this -- )
- 2swap 2over --> super --> cat
- --> set-hashcode
- ;
-
-end-class
-
-previous definitions
-\ #endif
+S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
+\ ** ficl/softwords/string.fr
+\ A useful dynamic string class
+\ John Sadler 14 Sep 1998
+\
+\ ** C - S T R I N G
+\ counted string, buffer sized dynamically
+\ Creation example:
+\ c-string --> new str
+\ s" arf arf!!" str --> set
+\ s" woof woof woof " str --> cat
+\ str --> type cr
+\
+
+.( loading ficl string class ) cr
+also oop definitions
+
+object subclass c-string
+ c-cell obj: .count
+ c-cell obj: .buflen
+ c-ptr obj: .buf
+ 32 constant min-buf
+
+ : get-count ( 2:this -- count ) my=[ .count get ] ;
+ : set-count ( count 2:this -- ) my=[ .count set ] ;
+
+ : ?empty ( 2:this -- flag ) --> get-count 0= ;
+
+ : get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
+ : set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
+
+ : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;
+ : set-buf { ptr len 2:this -- }
+ ptr this my=[ .buf set-ptr ]
+ len this my=> set-buflen
+ ;
+
+ \ set buffer to null and buflen to zero
+ : clr-buf ( 2:this -- )
+ 0 0 2over my=> set-buf
+ 0 -rot my=> set-count
+ ;
+
+ \ free the buffer if there is one, set buf pointer to null
+ : free-buf { 2:this -- }
+ this my=> get-buf
+ ?dup if
+ free
+ abort" c-string free failed"
+ this my=> clr-buf
+ endif
+ ;
+
+ \ guarantee buffer is large enough to hold size chars
+ : size-buf { size 2:this -- }
+ size 0< abort" need positive size for size-buf"
+ size 0= if
+ this --> free-buf exit
+ endif
+
+ \ force buflen to be a positive multiple of min-buf chars
+ my=> min-buf size over / 1+ * chars to size
+
+ \ if buffer is null, allocate one, else resize it
+ this --> get-buflen 0=
+ if
+ size allocate
+ abort" out of memory"
+ size this --> set-buf
+ size this --> set-buflen
+ exit
+ endif
+
+ size this --> get-buflen > if
+ this --> get-buf size resize
+ abort" out of memory"
+ size this --> set-buf
+ endif
+ ;
+
+ : set { c-addr u 2:this -- }
+ u this --> size-buf
+ u this --> set-count
+ c-addr this --> get-buf u move
+ ;
+
+ : get { 2:this -- c-addr u }
+ this --> get-buf
+ this --> get-count
+ ;
+
+ \ append string to existing one
+ : cat { c-addr u 2:this -- }
+ this --> get-count u + dup >r
+ this --> size-buf
+ c-addr this --> get-buf this --> get-count + u move
+ r> this --> set-count
+ ;
+
+ : type { 2:this -- }
+ this --> ?empty if ." (empty) " exit endif
+ this --> .buf --> get-ptr
+ this --> .count --> get
+ type
+ ;
+
+ : compare ( 2string 2:this -- n )
+ --> get
+ 2swap
+ --> get
+ 2swap compare
+ ;
+
+ : hashcode ( 2:this -- hashcode )
+ --> get hash
+ ;
+
+ \ destructor method (overrides object --> free)
+ : free ( 2:this -- ) 2dup --> free-buf object => free ;
+
+end-class
+
+c-string subclass c-hashstring
+ c-2byte obj: .hashcode
+
+ : set-hashcode { 2:this -- }
+ this --> super --> hashcode
+ this --> .hashcode --> set
+ ;
+
+ : get-hashcode ( 2:this -- hashcode )
+ --> .hashcode --> get
+ ;
+
+ : set ( c-addr u 2:this -- )
+ 2swap 2over --> super --> set
+ --> set-hashcode
+ ;
+
+ : cat ( c-addr u 2:this -- )
+ 2swap 2over --> super --> cat
+ --> set-hashcode
+ ;
+
+end-class
+
+previous definitions
+
+[endif]
diff --git a/softcore/win32.fr b/softcore/win32.fr
new file mode 100644
index 000000000000..eb0f627e19a5
--- /dev/null
+++ b/softcore/win32.fr
@@ -0,0 +1,211 @@
+\ **
+\ ** win32.fr
+\ ** submitted by Larry Hastings, larry@hastings.org
+\ **
+
+
+S" FICL_PLATFORM_OS" ENVIRONMENT? drop S" WIN32" compare-insensitive 0= [if]
+
+
+: GetProcAddress ( name-addr name-u hmodule -- address )
+ 3 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 2 \ cstringArgumentBitfield
+ (get-proc-address) \ functionAddress
+ [
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: LoadLibrary ( name-addr name-u -- hmodule )
+ 2 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 1 \ cstringArgumentBitfield
+ [
+ S" LoadLibraryA" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: FreeLibrary ( hmodule -- success )
+ 1 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" FreeLibrary" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+: DebugBreak ( -- )
+ 0 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" DebugBreak" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-void or literal \ flags
+ ]
+ multicall ;
+
+: OutputDebugString ( addr u -- )
+ 2 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 1 \ cstringArgumentBitfield
+ [
+ S" OutputDebugStringA" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-void or literal \ flags
+ ]
+ multicall ;
+
+: GetTickCount ( -- ticks )
+ 0 \ argumentCount
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ [
+ S" GetTickCount" kernel32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+S" user32.dll" LoadLibrary constant user32.dll
+
+: MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )
+ 6 \ argumentCount
+ 0 \ floatArgumentBitfield
+ [
+ 2 8 or literal \ cstringArgumentBitfield
+ S" MessageBoxA" user32.dll GetProcAddress literal \ functionAddress
+ multicall-calltype-function multicall-returntype-integer or literal \ flags
+ ]
+ multicall ;
+
+
+\ Constants for use with MessageBox
+\ the ID* names are possible return values.
+
+0x00000000 constant MB_OK
+0x00000001 constant MB_OKCANCEL
+0x00000002 constant MB_ABORTRETRYIGNORE
+0x00000003 constant MB_YESNOCANCEL
+0x00000004 constant MB_YESNO
+0x00000005 constant MB_RETRYCANCEL
+0x00000010 constant MB_ICONHAND
+0x00000020 constant MB_ICONQUESTION
+0x00000030 constant MB_ICONEXCLAMATION
+0x00000040 constant MB_ICONASTERISK
+0x00000080 constant MB_USERICON
+0x00000000 constant MB_DEFBUTTON1
+0x00000100 constant MB_DEFBUTTON2
+0x00000200 constant MB_DEFBUTTON3
+0x00000300 constant MB_DEFBUTTON4
+0x00000000 constant MB_APPLMODAL
+0x00001000 constant MB_SYSTEMMODAL
+0x00002000 constant MB_TASKMODAL
+0x00004000 constant MB_HELP
+0x00008000 constant MB_NOFOCUS
+0x00010000 constant MB_SETFOREGROUND
+0x00020000 constant MB_DEFAULT_DESKTOP_ONLY
+0x00040000 constant MB_TOPMOST
+0x00080000 constant MB_RIGHT
+0x00100000 constant MB_RTLREADING
+
+MB_ICONEXCLAMATION constant MB_ICONWARNING
+MB_ICONHAND constant MB_ICONERROR
+MB_ICONASTERISK constant MB_ICONINFORMATION
+MB_ICONHAND constant MB_ICONSTOP
+
+
+0x00200000 constant MB_SERVICE_NOTIFICATION
+0x00040000 constant MB_SERVICE_NOTIFICATION
+0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X
+
+0x0000000F constant MB_TYPEMASK
+0x000000F0 constant MB_ICONMASK
+0x00000F00 constant MB_DEFMASK
+0x00003000 constant MB_MODEMASK
+0x0000C000 constant MB_MISCMASK
+
+
+1 constant IDOK
+2 constant IDCANCEL
+3 constant IDABORT
+4 constant IDRETRY
+5 constant IDIGNORE
+6 constant IDYES
+7 constant IDNO
+8 constant IDCLOSE
+9 constant IDHELP
+
+
+\ ** old names
+: output-debug-string OutputDebugString ;
+: debug-break DebugBreak ;
+
+
+: uaddr->cstring { addr u | cstring -- cstring }
+ u 1+ allocate
+ 0= if
+ to cstring
+ addr cstring u move
+ 0 cstring u + c!
+ cstring
+ else
+ 0
+ endif
+ ;
+
+\ **
+\ ** The following four calls:
+\ ** callnativeFunction
+\ ** callcFunction
+\ ** callpascalFunction
+\ ** vcall
+\ ** are deprecated. Please use the more powerful "multicall" instead.
+\ **
+
+\ ** My original native function caller, reimplemented in Ficl using multicall.
+: callnativeFunction { functionAddress popStack -- }
+ 0 \ floatArgumentBitfield
+ 0 \ cstringArgumentBitfield
+ functionAddress \ functionAddress
+
+ [
+ multicall-calltype-function
+ multicall-returntype-integer or
+ multicall-reverse-arguments or
+ literal
+ ]
+
+ multicall
+ ;
+
+
+\ ** simple wrappers for callnativeFunction that specify the calling convention
+: callcfunction 1 callnativeFunction ;
+: callpascalfunction 0 callnativeFunction ;
+
+
+\ ** Guy Carver's "vcall" function, reimplemented in Ficl using multicall.
+: vcall { argumentCount index -- }
+ argumentCount 0x80000000 invert or \ cleaned-up argumentCount
+ 0 \ cstringArgumentBitfield
+ 0 \ cstringFlags
+ index \ index
+
+ \ flags:
+ argumentCount 0x80000000 and if multicall-returntype-integer else multicall-returntype-void endif
+
+ [
+ multicall-calltype-virtual-method
+ multicall-reverse-arguments or
+ literal
+ ] or
+
+ multicall
+ ;
+
+[endif]
+
diff --git a/softwords/jhlocal.fr b/softwords/jhlocal.fr
deleted file mode 100644
index a6e946a36462..000000000000
--- a/softwords/jhlocal.fr
+++ /dev/null
@@ -1,103 +0,0 @@
-\ #if FICL_WANT_LOCALS
-\ ** ficl/softwords/jhlocal.fr
-\ ** stack comment style local syntax...
-\ { a b c | cleared -- d e }
-\ variables before the "|" are initialized in reverse order
-\ from the stack. Those after the "|" are zero initialized.
-\ Anything between "--" and "}" is treated as comment
-\ Uses locals...
-\ locstate: 0 = looking for | or -- or }}
-\ 1 = found |
-\ 2 = found --
-\ 3 = found }
-\ 4 = end of line
-\
-\ revised 2 June 2000 - { | a -- } now works correctly
-.( loading Johns-Hopkins locals ) cr
-hide
-
-0 constant zero
-
-
-: ?-- ( c-addr u -- c-addr u flag )
- 2dup s" --" compare 0= ;
-: ?} ( c-addr u -- c-addr u flag )
- 2dup s" }" compare 0= ;
-: ?| ( c-addr u -- c-addr u flag )
- 2dup s" |" compare 0= ;
-
-\ examine name - if it's a 2local (starts with "2:"),
-\ nibble the prefix (the "2:") off the name and push true.
-\ Otherwise push false
-\ Problem if the local is named "2:" - we fall off the end...
-: ?2loc ( c-addr u -- c-addr u flag )
- over dup c@ [char] 2 =
- swap 1+ c@ [char] : = and
- if
- 2 - swap char+ char+ swap \ dcs/jws: nibble the '2:'
- true
- else
- false
- endif
-;
-
-: ?delim ( c-addr u -- state | c-addr u 0 )
- ?| if 2drop 1 exit endif
- ?-- if 2drop 2 exit endif
- ?} if 2drop 3 exit endif
- dup 0=
- if 2drop 4 exit endif
- 0
-;
-
-set-current
-
-: {
- 0 dup locals| locstate |
-
- \ stack locals until we hit a delimiter
- begin
- parse-word \ ( nLocals c-addr u )
- ?delim dup to locstate
- 0= while
- rot 1+ \ ( c-addr u ... c-addr u nLocals )
- repeat
-
- \ now unstack the locals
- 0 ?do
- ?2loc if (2local) else (local) endif
- loop \ ( )
-
- \ zero locals until -- or }
- locstate 1 = if
- begin
- parse-word
- ?delim dup to locstate
- 0= while
- ?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
- 3 < while
- locstate 0= if 2drop endif
- repeat
- endif
-
- locstate 3 <> abort" syntax error in { } local line"
-; immediate compile-only
-
-previous
-\ #endif
-
diff --git a/softwords/makefile b/softwords/makefile
deleted file mode 100644
index 55edd857cb7b..000000000000
--- a/softwords/makefile
+++ /dev/null
@@ -1,9 +0,0 @@
-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
- cp softcore.c ..
-
-clean:
- rm *.c
-
diff --git a/softwords/oo.fr.bak b/softwords/oo.fr.bak
deleted file mode 100644
index afe8edb38b80..000000000000
--- a/softwords/oo.fr.bak
+++ /dev/null
@@ -1,678 +0,0 @@
-\ #if FICL_WANT_OOP
-\ ** ficl/softwords/oo.fr
-\ ** F I C L O - O E X T E N S I O N S
-\ ** john sadler aug 1998
-
-.( loading ficl O-O extensions ) cr
-17 ficl-vocabulary oop
-also oop definitions
-
-\ Design goals:
-\ 0. Traditional OOP: late binding by default for safety.
-\ Early binding if you ask for it.
-\ 1. Single inheritance
-\ 2. Object aggregation (has-a relationship)
-\ 3. Support objects in the dictionary and as proxies for
-\ existing structures (by reference):
-\ *** A ficl object can wrap a C struct ***
-\ 4. Separate name-spaces for methods - methods are
-\ only visible in the context of a class / object
-\ 5. Methods can be overridden, and subclasses can add methods.
-\ No limit on number of methods.
-
-\ General info:
-\ Classes are objects, too: all classes are instances of METACLASS
-\ All classes are derived (by convention) from OBJECT. This
-\ base class provides a default initializer and superclass
-\ access method
-
-\ A ficl object binds instance storage (payload) to a class.
-\ object ( -- instance class )
-\ All objects push their payload address and class address when
-\ 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
-\ of objects created by the class. A class is an object.
-\ The NEW method creates and initializes an instance of a class.
-\ Classes have this footprint:
-\ cell 0: parent class address
-\ cell 1: wordlist ID
-\ cell 2: size of instance's payload
-
-\ Methods expect an object couple ( instance class )
-\ 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, 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 !
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** 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...
-\
-
-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 )
- 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
-;
-
-: exec-method ( instance class c-addr u -- <method-signature> )
- lookup-method execute
-;
-
-\ Method lookup operator takes a class-addr and instance-addr
-\ and executes the method from the class's wordlist if
-\ interpreting. If compiling, bind late.
-\
-: --> ( instance class -- ??? )
- state @ 0= if
- find-method-xt execute
- else
- parse-method postpone exec-method
- endif
-; immediate
-
-\ Method lookup with CATCH in case of exceptions
-: c-> ( instance class -- ?? exc-flag )
- state @ 0= if
- find-method-xt catch
- else
- parse-method postpone catch-method
- endif
-; immediate
-
-\ 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 ;
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** E A R L Y B I N D I N G
-\ Early binding operator compiles code to execute a method
-\ given its class at compile time. Classes are immediate,
-\ so they leave their cell-pair on the stack when compiling.
-\ Example:
-\ : get-wid metaclass => .wid @ ;
-\ Usage
-\ my-class get-wid ( -- wid-of-my-class )
-\
-1 ficl-named-wordlist instance-vars
-instance-vars dup >search ficl-set-current
-
-: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
- drop find-method-xt compile, drop
-; immediate compile-only
-
-: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
- current-class @ dup postpone =>
-; immediate compile-only
-
-: my=[ \ same as my=> , but binds a chain of methods
- current-class @
- begin
- parse-word 2dup
- s" ]" compare while ( class c-addr u )
- lookup-method nip dup ( xt xt )
- compile, >body cell+ @ ( class' )
- repeat 2drop drop
-; immediate compile-only
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** I N S T A N C E V A R I A B L E S
-\ Instance variables (IV) are represented by words in the class's
-\ private wordlist. Each IV word contains the offset
-\ of the IV it represents, and runs code to add that offset
-\ to the base address of an instance when executed.
-\ The metaclass SUB method, defined below, leaves the address
-\ of the new class's offset field and its initial size on the
-\ stack for these words to update. When a class definition is
-\ complete, END-CLASS saves the final size in the class's size
-\ field, and restores the search order and compile wordlist to
-\ prior state. Note that these words are hidden in their own
-\ wordlist to prevent accidental use outside a SUB END-CLASS pair.
-\
-: do-instance-var
- does> ( instance class addr[offset] -- addr[field] )
- nip @ +
-;
-
-: addr-units: ( offset size "name" -- offset' )
- create over , +
- do-instance-var
-;
-
-: chars: \ ( offset nCells "name" -- offset' ) Create n char member.
- chars addr-units: ;
-
-: char: \ ( offset nCells "name" -- offset' ) Create 1 char member.
- 1 chars: ;
-
-: cells: ( offset nCells "name" -- offset' )
- cells >r aligned r> addr-units:
-;
-
-: cell: ( offset nCells "name" -- offset' )
- 1 cells: ;
-
-\ Aggregate an object into the class...
-\ Needs the class of the instance to create
-\ Example: object obj: m_obj
-\
-: do-aggregate
- does> ( instance class pfa -- a-instance a-class )
- 2@ ( inst class a-class a-offset )
- 2swap drop ( a-class a-offset inst )
- + swap ( a-inst a-class )
-;
-
-: obj: ( offset class meta "name" -- offset' )
- locals| meta class offset |
- create offset , class ,
- class meta --> get-size offset +
- do-aggregate
-;
-
-\ Aggregate an array of objects into a class
-\ Usage example:
-\ 3 my-class array: my-array
-\ Makes an instance variable array of 3 instances of my-class
-\ named my-array.
-\
-: array: ( offset n class meta "name" -- offset' )
- locals| meta class nobjs offset |
- create offset , class ,
- class meta --> get-size nobjs * offset +
- do-aggregate
-;
-
-\ Aggregate a pointer to an object: REF is a member variable
-\ whose class is set at compile time. This is useful for wrapping
-\ data structures in C, where there is only a pointer and the type
-\ it refers to is known. If you want polymorphism, see c_ref
-\ in classes.fr. REF is only useful for pre-initialized structures,
-\ since there's no supported way to set one.
-: ref: ( offset class meta "name" -- offset' )
- locals| meta class offset |
- create offset , class ,
- offset cell+
- does> ( inst class pfa -- ptr-inst ptr-class )
- 2@ ( inst class ptr-class ptr-offset )
- 2swap drop + @ swap
-;
-
-\ #if FICL_WANT_VCALL
-\ vcall extensions contributed by Guy Carver
-: vcall: ( paramcnt "name" -- )
- current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
- create , , \ ( paramcnt index -- )
- does> \ ( inst class pfa -- ptr-inst ptr-class )
- nip 2@ vcall \ ( params offset inst class offset -- )
-;
-
-: vcallr: 0x80000000 or vcall: ; \ Call with return address desired.
-
-\ #if FICL_WANT_FLOAT
-: vcallf: \ ( paramcnt -<name>- f: r )
- 0x80000000 or
- current-class @ 8 + dup @ dup 1+ rot ! \ Kludge fix to get to .vtCount before it's defined.
- create , , \ ( paramcnt index -- )
- does> \ ( inst class pfa -- ptr-inst ptr-class )
- nip 2@ vcall f> \ ( params offset inst class offset -- f: r )
-;
-\ #endif /* FLOAT */
-\ #endif /* VCALL */
-
-\ END-CLASS terminates construction of a class by storing
-\ the size of its instance variables in the class's size field
-\ ( -- old-wid addr[size] 0 )
-\
-: end-class ( old-wid addr[size] size -- )
- swap ! set-current
- search> drop \ pop struct builder wordlist
-;
-
-\ See resume-class (a metaclass method) below for usage
-\ This is equivalent to end-class for now, but that will change
-\ when we support vtable bindings.
-: suspend-class ( old-wid addr[size] size -- ) end-class ;
-
-set-current previous
-\ E N D I N S T A N C E V A R I A B L E S
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ D O - D O - I N S T A N C E
-\ Makes a class method that contains the code for an
-\ instance of the class. This word gets compiled into
-\ the wordlist of every class by the SUB method.
-\ PRECONDITION: current-class contains the class address
-\ why use a state variable instead of the stack?
-\ >> Stack state is not well-defined during compilation (there are
-\ >> control structure match codes on the stack, of undefined size
-\ >> easiest way around this is use of this thread-local variable
-\
-: do-do-instance ( -- )
- s" : .do-instance does> [ current-class @ ] literal ;"
- evaluate
-;
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** M E T A C L A S S
-\ Every class is an instance of metaclass. This lets
-\ classes have methods that are different from those
-\ of their instances.
-\ Classes are IMMEDIATE to make early binding simpler
-\ See above...
-\
-:noname
- wordlist
- create
- immediate
- 0 , \ NULL parent class
- dup , \ wid
-\ #if FICL_WANT_VCALL
- 4 cells , \ instance size
-\ #else
- 3 cells , \ instance size
-\ #endif
- ficl-set-current
- does> dup
-; execute metaclass
-\ now brand OBJECT's wordlist (so that ORDER can display it by name)
-metaclass drop cell+ @ brand-wordlist
-
-metaclass drop current-class !
-do-do-instance
-
-\
-\ C L A S S M E T H O D S
-\
-instance-vars >search
-
-create .super ( class metaclass -- parent-class )
- 0 cells , do-instance-var
-
-create .wid ( class metaclass -- wid ) \ return wid of class
- 1 cells , do-instance-var
-
-\ #if FICL_WANT_VCALL
-create .vtCount \ Number of VTABLE methods, if any
- 2 cells , do-instance-var
-
-create .size ( class metaclass -- size ) \ return class's payload size
- 3 cells , do-instance-var
-\ #else
-create .size ( class metaclass -- size ) \ return class's payload size
- 2 cells , do-instance-var
-\ #endif
-
-: get-size metaclass => .size @ ;
-: get-wid metaclass => .wid @ ;
-: get-super metaclass => .super @ ;
-\ #if FICL_WANT_VCALL
-: get-vtCount metaclass => .vtCount @ ;
-: get-vtAdd metaclass => .vtCount ;
-\ #endif
-
-\ create an uninitialized instance of a class, leaving
-\ the address of the new instance and its class
-\
-: instance ( class metaclass "name" -- instance class )
- locals| meta parent |
- create
- here parent --> .do-instance \ ( inst class )
- parent meta metaclass => get-size
- allot \ allocate payload space
-;
-
-\ create an uninitialized array
-: array ( n class metaclass "name" -- n instance class )
- locals| meta parent nobj |
- create nobj
- here parent --> .do-instance \ ( nobj inst class )
- parent meta metaclass => get-size
- nobj * allot \ allocate payload space
-;
-
-\ create an initialized instance
-\
-: new \ ( class metaclass "name" -- )
- metaclass => instance --> init
-;
-
-\ create an initialized array of instances
-: new-array ( n class metaclass "name" -- )
- metaclass => array
- --> array-init
-;
-
-\ Create an anonymous initialized instance from the heap
-: alloc \ ( class metaclass -- instance class )
- locals| meta class |
- class meta metaclass => get-size allocate ( -- addr fail-flag )
- abort" allocate failed " ( -- addr )
- class 2dup --> init
-;
-
-\ Create an anonymous array of initialized instances from the heap
-: alloc-array \ ( n class metaclass -- instance class )
- locals| meta class nobj |
- class meta metaclass => get-size
- nobj * allocate ( -- addr fail-flag )
- abort" allocate failed " ( -- addr )
- nobj over class --> array-init
- class
-;
-
-\ Create an anonymous initialized instance from the dictionary
-: allot { 2:this -- 2:instance }
- here ( instance-address )
- this my=> get-size allot
- this drop 2dup --> init
-;
-
-\ Create an anonymous array of initialized instances from the dictionary
-: allot-array { nobj 2:this -- 2:instance }
- here ( instance-address )
- this my=> get-size nobj * allot
- this drop 2dup ( 2instance 2instance )
- nobj -rot --> array-init
-;
-
-\ create a proxy object with initialized payload address given
-: ref ( instance-addr class metaclass "name" -- )
- drop create , ,
- does> 2@
-;
-
-\ suspend-class and resume-class help to build mutually referent classes.
-\ Example:
-\ object subclass c-akbar
-\ suspend-class ( put akbar on hold while we define jeff )
-\ object subclass c-jeff
-\ c-akbar ref: .akbar
-\ ( and whatever else comprises this class )
-\ end-class ( done with c-jeff )
-\ c-akbar --> resume-class
-\ c-jeff ref: .jeff
-\ ( and whatever else goes in c-akbar )
-\ end-class ( done with c-akbar )
-\
-: resume-class { 2:this -- old-wid addr[size] size }
- this --> .wid @ ficl-set-current ( old-wid )
- this --> .size dup @ ( old-wid addr[size] size )
- instance-vars >search
-;
-
-\ create a subclass
-\ This method leaves the stack and search order ready for instance variable
-\ building. Pushes the instance-vars wordlist onto the search order,
-\ and sets the compilation wordlist to be the private wordlist of the
-\ new class. The class's wordlist is deliberately NOT in the search order -
-\ to prevent methods from getting used with wrong data.
-\ Postcondition: leaves the address of the new class in current-class
-: sub ( class metaclass "name" -- old-wid addr[size] size )
- wordlist
- locals| wid meta parent |
- parent meta metaclass => get-wid
- wid wid-set-super \ set superclass
- create immediate \ get the subclass name
- wid brand-wordlist \ label the subclass wordlist
- here current-class ! \ prep for do-do-instance
- parent , \ save parent class
- wid , \ save wid
-\ #if FICL_WANT_VCALL
- parent meta --> get-vtCount ,
-\ #endif
- here parent meta --> get-size dup , ( addr[size] size )
- metaclass => .do-instance
- wid ficl-set-current -rot
- do-do-instance
- instance-vars >search \ push struct builder wordlist
-;
-
-\ OFFSET-OF returns the offset of an instance variable
-\ from the instance base address. If the next token is not
-\ the name of in instance variable method, you get garbage
-\ results -- there is no way at present to check for this error.
-: offset-of ( class metaclass "name" -- offset )
- drop find-method-xt nip >body @ ;
-
-\ ID returns the string name cell-pair of its class
-: id ( class metaclass -- c-addr u )
- drop body> >name ;
-
-\ list methods of the class
-: methods \ ( class meta -- )
- locals| meta class |
- begin
- class body> >name type ." methods:" cr
- class meta --> get-wid >search words cr previous
- class meta metaclass => get-super
- dup to class
- 0= until cr
-;
-
-\ list class's ancestors
-: pedigree ( class meta -- )
- locals| meta class |
- begin
- class body> >name type space
- class meta metaclass => get-super
- dup to class
- 0= until cr
-;
-
-\ decompile an instance method
-: see ( class meta -- )
- metaclass => get-wid >search see previous ;
-
-\ debug a method of metaclass
-\ Eg: my-object --> debug my-method
-: debug ( class meta -- )
- find-method-xt debug-xt ;
-
-previous set-current
-\ E N D M E T A C L A S S
-
-\ ** META is a nickname for the address of METACLASS...
-metaclass drop
-constant meta
-
-\ ** SUBCLASS is a nickname for a class's SUB method...
-\ Subclass compilation ends when you invoke end-class
-\ This method is late bound for safety...
-: subclass --> sub ;
-
-\ #if FICL_WANT_VCALL
-\ VTABLE Support extensions (Guy Carver)
-\ object --> sub mine hasvtable
-: hasvtable 4 + ; immediate
-\ #endif
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** O B J E C T
-\ Root of all classes
-:noname
- wordlist
- create immediate
- 0 , \ NULL parent class
- dup , \ wid
- 0 , \ instance size
- ficl-set-current
- does> meta
-; execute object
-\ now brand OBJECT's wordlist (so that ORDER can display it by name)
-object drop cell+ @ brand-wordlist
-
-object drop current-class !
-do-do-instance
-instance-vars >search
-
-\ O B J E C T M E T H O D S
-\ Convert instance cell-pair to class cell-pair
-\ Useful for binding class methods from an instance
-: class ( instance class -- class metaclass )
- nip meta ;
-
-\ default INIT method zero fills an instance
-: init ( instance class -- )
- meta
- metaclass => get-size ( inst size )
- erase ;
-
-\ Apply INIT to an array of NOBJ objects...
-\
-: array-init ( nobj inst class -- )
- 0 dup locals| &init &next class inst |
- \
- \ bind methods outside the loop to save time
- \
- class s" init" lookup-method to &init
- s" next" lookup-method to &next
- drop
- 0 ?do
- inst class 2dup
- &init execute
- &next execute drop to inst
- loop
-;
-
-\ free storage allocated to a heap instance by alloc or alloc-array
-\ NOTE: not protected against errors like FREEing something that's
-\ really in the dictionary.
-: free \ ( instance class -- )
- drop free
- abort" free failed "
-;
-
-\ Instance aliases for common class methods
-\ Upcast to parent class
-: super ( instance class -- instance parent-class )
- meta metaclass => get-super ;
-
-: pedigree ( instance class -- )
- object => class
- metaclass => pedigree ;
-
-: size ( instance class -- sizeof-instance )
- object => class
- metaclass => get-size ;
-
-: methods ( instance class -- )
- object => class
- metaclass => methods ;
-
-\ Array indexing methods...
-\ Usage examples:
-\ 10 object-array --> index
-\ obj --> next
-\
-: index ( n instance class -- instance[n] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size * ( n*size )
- inst + class ;
-
-: next ( instance[n] class -- instance[n+1] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size
- inst +
- class ;
-
-: prev ( instance[n] class -- instance[n-1] class )
- locals| class inst |
- inst class
- object => class
- metaclass => get-size
- inst swap -
- class ;
-
-: debug ( 2this -- ?? )
- find-method-xt debug-xt ;
-
-previous set-current
-\ E N D O B J E C T
-
-\ reset to default search order
-only definitions
-
-\ redefine oop in default search order to put OOP words in the search order and make them
-\ the compiling wordlist...
-: oop only also oop definitions ;
-\ #endif \ No newline at end of file
diff --git a/softwords/softcore.bat b/softwords/softcore.bat
deleted file mode 100644
index 85633280495f..000000000000
--- a/softwords/softcore.bat
+++ /dev/null
@@ -1 +0,0 @@
-perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
diff --git a/softwords/softcore.pl b/softwords/softcore.pl
deleted file mode 100755
index cb521ad9ec3b..000000000000
--- a/softwords/softcore.pl
+++ /dev/null
@@ -1,144 +0,0 @@
-#! /usr/bin/perl
-# Convert forth source files to a giant C string
-
-$now = localtime;
-
-print <<EOF
-/*******************************************************************
-** 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: $now
-*******************************************************************/
-/*
-** 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
-EOF
-;
-
-$commenting = 0;
-
-while (<>) {
- s"\n$""; # remove EOL
- s/\"/\\\"/g; # escape quotes
-
- #
- # emit lines beginnning with "\ **" as C comments
- #
- if (/^\\\s\*\*/) {
- s"^\\ "";
- if ($commenting == 0) {
- print "/*\n";
- }
- $commenting = 1;
- print "$_\n";
- next;
- }
-
- if ($commenting == 1) {
- print "*/\n";
- }
-
- $commenting = 0;
-
- #
- # ignore empty lines and lines containing
- # only empty comments
- #
- next if /^\s*\\\s*$/;
- next if /^\s*$/;
-
- #
- # pass commented preprocessor directives
- # == lines starting with "\ #"
- # (supports single line directives only)
- #
- if (/^\\\s#/) {
- s"^\\ "";
- print "$_\n";
- next;
- }
-
- next if /^\s*\\ /; # toss all other \ comment lines
- s"\\\s+.*$"" ; # lop off trailing \ comments
- s"\s+\(\s.*?\)""g; # delete ( ) comments
- s"^\s+""; # remove leading spaces
- s"\s+$""; # remove trailing spaces
-
- #
- # emit whatever's left as quoted string fragments
- #
-# $out = " \"" . $_ . " \\n\"";
- $out = " \"" . $_ . " \"";
- print "$out\n";
-}
-
-print <<EOF
-#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;
-}
-
-
-EOF
-;
-
diff --git a/softwords/softcore.py b/softwords/softcore.py
deleted file mode 100644
index f5f3d8dc9cc3..000000000000
--- a/softwords/softcore.py
+++ /dev/null
@@ -1,152 +0,0 @@
-#! 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.py
-** 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.py
-*/
-/*
-** 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;
-}
-
-
-"""
diff --git a/softwords/softcore.py.bat b/softwords/softcore.py.bat
deleted file mode 100644
index 20ada6f0bc9b..000000000000
--- a/softwords/softcore.py.bat
+++ /dev/null
@@ -1 +0,0 @@
-python softcore.py softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
diff --git a/softwords/win32.fr b/softwords/win32.fr
deleted file mode 100644
index b34f4e329481..000000000000
--- a/softwords/win32.fr
+++ /dev/null
@@ -1,10 +0,0 @@
-\ **
-\ ** win32.fr
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-
-
-\ ** simple wrappers for callnativeFunction that specify the calling convention
-: callcfunction 1 callnativeFunction ;
-: callpascalfunction 0 callnativeFunction ;
-
diff --git a/stack.c b/stack.c
index 84e7da0fb8a2..6e6f813b1520 100644
--- 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 01:24:35-07 jsadler Exp jsadler $
+** $Id: stack.c,v 1.11 2010/08/12 13:57:22 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -11,9 +11,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -44,82 +44,75 @@
#include "ficl.h"
-#define STKDEPTH(s) ((s)->sp - (s)->base)
+#define STKDEPTH(s) (((s)->top - (s)->base) + 1)
/*
** N O T E: Stack convention:
**
-** sp points to the first available cell
-** push: store value at sp, increment sp
-** pop: decrement sp, fetch value at sp
+** THIS CHANGED IN FICL 4.0!
+**
+** top points to the *current* top data value
+** push: increment top, store value at top
+** pop: fetch value at top, decrement top
** Stack grows from low to high memory
*/
/*******************************************************************
v m C h e c k S t a c k
** Check the parameter stack for underflow or overflow.
-** nCells controls the type of check: if nCells is zero,
+** size controls the type of check: if size is zero,
** the function checks the stack state for underflow and overflow.
-** If nCells > 0, checks to see that the stack has room to push
+** If size > 0, checks to see that the stack has room to push
** that many cells. If less than zero, checks to see that the
** stack has room to pop that many cells. If any test fails,
** the function throws (via vmThrow) a VM_ERREXIT exception.
*******************************************************************/
-void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells)
+void ficlStackCheck(ficlStack *stack, int popCells, int pushCells)
+#if FICL_ROBUST >= 1
{
- FICL_STACK *pStack = pVM->pStack;
- int nFree = pStack->base + pStack->nCells - pStack->sp;
+ int nFree = stack->size - STKDEPTH(stack);
- if (popCells > STKDEPTH(pStack))
+ if (popCells > STKDEPTH(stack))
{
- vmThrowErr(pVM, "Error: stack underflow");
+ ficlVmThrowError(stack->vm, "Error: %s stack underflow", stack->name);
}
if (nFree < pushCells - popCells)
{
- vmThrowErr(pVM, "Error: stack overflow");
+ ficlVmThrowError(stack->vm, "Error: %s stack overflow", stack->name);
}
return;
}
-
-#if FICL_WANT_FLOAT
-void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells)
+#else /* FICL_ROBUST >= 1 */
{
- FICL_STACK *fStack = pVM->fStack;
- int nFree = fStack->base + fStack->nCells - fStack->sp;
-
- if (popCells > STKDEPTH(fStack))
- {
- vmThrowErr(pVM, "Error: float stack underflow");
- }
-
- if (nFree < pushCells - popCells)
- {
- vmThrowErr(pVM, "Error: float stack overflow");
- }
+ FICL_IGNORE(stack);
+ FICL_IGNORE(popCells);
+ FICL_IGNORE(pushCells);
}
-#endif
+#endif /* FICL_ROBUST >= 1 */
/*******************************************************************
s t a c k C r e a t e
**
*******************************************************************/
-FICL_STACK *stackCreate(unsigned nCells)
+ficlStack *ficlStackCreate(ficlVm *vm, char *name, unsigned size)
{
- size_t size = sizeof (FICL_STACK) + nCells * sizeof (CELL);
- FICL_STACK *pStack = ficlMalloc(size);
+ size_t totalSize = sizeof (ficlStack) + (size * sizeof (ficlCell));
+ ficlStack *stack = ficlMalloc(totalSize);
-#if FICL_ROBUST
- assert (nCells != 0);
- assert (pStack != NULL);
-#endif
+ FICL_VM_ASSERT(vm, size != 0);
+ FICL_VM_ASSERT(vm, stack != NULL);
+
+ stack->size = size;
+ stack->frame = NULL;
+
+ stack->vm = vm;
+ stack->name = name;
- pStack->nCells = nCells;
- pStack->sp = pStack->base;
- pStack->pFrame = NULL;
- return pStack;
+ ficlStackReset(stack);
+ return stack;
}
@@ -128,10 +121,10 @@ FICL_STACK *stackCreate(unsigned nCells)
**
*******************************************************************/
-void stackDelete(FICL_STACK *pStack)
+void ficlStackDestroy(ficlStack *stack)
{
- if (pStack)
- ficlFree(pStack);
+ if (stack)
+ ficlFree(stack);
return;
}
@@ -141,9 +134,9 @@ void stackDelete(FICL_STACK *pStack)
**
*******************************************************************/
-int stackDepth(FICL_STACK *pStack)
+int ficlStackDepth(ficlStack *stack)
{
- return STKDEPTH(pStack);
+ return STKDEPTH(stack);
}
/*******************************************************************
@@ -151,12 +144,10 @@ int stackDepth(FICL_STACK *pStack)
**
*******************************************************************/
-void stackDrop(FICL_STACK *pStack, int n)
+void ficlStackDrop(ficlStack *stack, int n)
{
-#if FICL_ROBUST
- assert(n > 0);
-#endif
- pStack->sp -= n;
+ FICL_VM_ASSERT(stack->vm, n > 0);
+ stack->top -= n;
return;
}
@@ -166,14 +157,14 @@ void stackDrop(FICL_STACK *pStack, int n)
**
*******************************************************************/
-CELL stackFetch(FICL_STACK *pStack, int n)
+ficlCell ficlStackFetch(ficlStack *stack, int n)
{
- return pStack->sp[-n-1];
+ return stack->top[-n];
}
-void stackStore(FICL_STACK *pStack, int n, CELL c)
+void ficlStackStore(ficlStack *stack, int n, ficlCell c)
{
- pStack->sp[-n-1] = c;
+ stack->top[-n] = c;
return;
}
@@ -183,26 +174,27 @@ void stackStore(FICL_STACK *pStack, int n, CELL c)
**
*******************************************************************/
-CELL stackGetTop(FICL_STACK *pStack)
+ficlCell ficlStackGetTop(ficlStack *stack)
{
- return pStack->sp[-1];
+ return stack->top[0];
}
+#if FICL_WANT_LOCALS
/*******************************************************************
s t a c k L i n k
** Link a frame using the stack's frame pointer. Allot space for
-** nCells cells in the frame
-** 1) Push pFrame
-** 2) pFrame = sp
-** 3) sp += nCells
+** size cells in the frame
+** 1) Push frame
+** 2) frame = top
+** 3) top += size
*******************************************************************/
-void stackLink(FICL_STACK *pStack, int nCells)
+void ficlStackLink(ficlStack *stack, int size)
{
- stackPushPtr(pStack, pStack->pFrame);
- pStack->pFrame = pStack->sp;
- pStack->sp += nCells;
+ ficlStackPushPointer(stack, stack->frame);
+ stack->frame = stack->top + 1;
+ stack->top += size;
return;
}
@@ -210,16 +202,17 @@ void stackLink(FICL_STACK *pStack, int nCells)
/*******************************************************************
s t a c k U n l i n k
** Unink a stack frame previously created by stackLink
-** 1) sp = pFrame
-** 2) pFrame = pop()
+** 1) top = frame
+** 2) frame = pop()
*******************************************************************/
-void stackUnlink(FICL_STACK *pStack)
+void ficlStackUnlink(ficlStack *stack)
{
- pStack->sp = pStack->pFrame;
- pStack->pFrame = stackPopPtr(pStack);
+ stack->top = stack->frame - 1;
+ stack->frame = ficlStackPopPointer(stack);
return;
}
+#endif /* FICL_WANT_LOCALS */
/*******************************************************************
@@ -227,9 +220,9 @@ void stackUnlink(FICL_STACK *pStack)
**
*******************************************************************/
-void stackPick(FICL_STACK *pStack, int n)
+void ficlStackPick(ficlStack *stack, int n)
{
- stackPush(pStack, stackFetch(pStack, n));
+ ficlStackPush(stack, ficlStackFetch(stack, n));
return;
}
@@ -239,73 +232,107 @@ void stackPick(FICL_STACK *pStack, int n)
**
*******************************************************************/
-CELL stackPop(FICL_STACK *pStack)
+ficlCell ficlStackPop(ficlStack *stack)
+{
+ return *stack->top--;
+}
+
+void *ficlStackPopPointer(ficlStack *stack)
+{
+ return (*stack->top--).p;
+}
+
+ficlUnsigned ficlStackPopUnsigned(ficlStack *stack)
{
- return *--pStack->sp;
+ return (*stack->top--).u;
}
-void *stackPopPtr(FICL_STACK *pStack)
+ficlInteger ficlStackPopInteger(ficlStack *stack)
{
- return (*--pStack->sp).p;
+ return (*stack->top--).i;
}
-FICL_UNS stackPopUNS(FICL_STACK *pStack)
+ficl2Integer ficlStackPop2Integer(ficlStack *stack)
{
- return (*--pStack->sp).u;
+ ficl2Integer ret;
+ ficlInteger high = ficlStackPopInteger(stack);
+ ficlInteger low = ficlStackPopInteger(stack);
+ FICL_2INTEGER_SET(high, low, ret);
+ return ret;
}
-FICL_INT stackPopINT(FICL_STACK *pStack)
+ficl2Unsigned ficlStackPop2Unsigned(ficlStack *stack)
{
- return (*--pStack->sp).i;
+ ficl2Unsigned ret;
+ ficlUnsigned high = ficlStackPopUnsigned(stack);
+ ficlUnsigned low = ficlStackPopUnsigned(stack);
+ FICL_2UNSIGNED_SET(high, low, ret);
+ return ret;
}
+
#if (FICL_WANT_FLOAT)
-float stackPopFloat(FICL_STACK *pStack)
+ficlFloat ficlStackPopFloat(ficlStack *stack)
{
- return (*(--pStack->sp)).f;
+ return (*stack->top--).f;
}
#endif
+
/*******************************************************************
s t a c k P u s h
**
*******************************************************************/
-void stackPush(FICL_STACK *pStack, CELL c)
+void ficlStackPush(ficlStack *stack, ficlCell c)
+{
+ *++stack->top = c;
+}
+
+void ficlStackPushPointer(ficlStack *stack, void *ptr)
{
- *pStack->sp++ = c;
+ *++stack->top = FICL_LVALUE_TO_CELL(ptr);
}
-void stackPushPtr(FICL_STACK *pStack, void *ptr)
+void ficlStackPushInteger(ficlStack *stack, ficlInteger i)
{
- *pStack->sp++ = LVALUEtoCELL(ptr);
+ *++stack->top = FICL_LVALUE_TO_CELL(i);
}
-void stackPushUNS(FICL_STACK *pStack, FICL_UNS u)
+void ficlStackPushUnsigned(ficlStack *stack, ficlUnsigned u)
{
- *pStack->sp++ = LVALUEtoCELL(u);
+ *++stack->top = FICL_LVALUE_TO_CELL(u);
}
-void stackPushINT(FICL_STACK *pStack, FICL_INT i)
+void ficlStackPush2Unsigned(ficlStack *stack, ficl2Unsigned du)
{
- *pStack->sp++ = LVALUEtoCELL(i);
+ ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_LOW(du));
+ ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_HIGH(du));
+ return;
+}
+
+void ficlStackPush2Integer(ficlStack *stack, ficl2Integer di)
+{
+ ficlStackPush2Unsigned(stack, FICL_2INTEGER_TO_2UNSIGNED(di));
+ return;
}
#if (FICL_WANT_FLOAT)
-void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f)
+void ficlStackPushFloat(ficlStack *stack, ficlFloat f)
{
- *pStack->sp++ = LVALUEtoCELL(f);
+ *++stack->top = FICL_LVALUE_TO_CELL(f);
}
#endif
+
/*******************************************************************
s t a c k R e s e t
**
*******************************************************************/
-void stackReset(FICL_STACK *pStack)
+void ficlStackReset(ficlStack *stack)
{
- pStack->sp = pStack->base;
+ stack->top = stack->base - 1;
return;
}
@@ -318,36 +345,36 @@ void stackReset(FICL_STACK *pStack)
** upward as needed to fill the hole.
*******************************************************************/
-void stackRoll(FICL_STACK *pStack, int n)
+void ficlStackRoll(ficlStack *stack, int n)
{
- CELL c;
- CELL *pCell;
+ ficlCell c;
+ ficlCell *cell;
if (n == 0)
return;
else if (n > 0)
{
- pCell = pStack->sp - n - 1;
- c = *pCell;
+ cell = stack->top - n;
+ c = *cell;
- for (;n > 0; --n, pCell++)
+ for (;n > 0; --n, cell++)
{
- *pCell = pCell[1];
+ *cell = cell[1];
}
- *pCell = c;
+ *cell = c;
}
else
{
- pCell = pStack->sp - 1;
- c = *pCell;
+ cell = stack->top;
+ c = *cell;
- for (; n < 0; ++n, pCell--)
+ for (; n < 0; ++n, cell--)
{
- *pCell = pCell[-1];
+ *cell = cell[-1];
}
- *pCell = c;
+ *cell = c;
}
return;
}
@@ -358,9 +385,31 @@ void stackRoll(FICL_STACK *pStack, int n)
**
*******************************************************************/
-void stackSetTop(FICL_STACK *pStack, CELL c)
+void ficlStackSetTop(ficlStack *stack, ficlCell c)
+{
+ FICL_STACK_CHECK(stack, 1, 1);
+ stack->top[0] = c;
+ return;
+}
+
+
+
+
+void ficlStackWalk(ficlStack *stack, ficlStackWalkFunction callback, void *context, ficlInteger bottomToTop)
{
- pStack->sp[-1] = c;
+ int i;
+ int depth;
+ ficlCell *cell;
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ depth = ficlStackDepth(stack);
+ cell = bottomToTop ? stack->base : stack->top;
+ for (i = 0; i < depth; i++)
+ {
+ if (callback(context, cell) == FICL_FALSE)
+ break;
+ cell += bottomToTop ? 1 : -1;
+ }
return;
}
diff --git a/sysdep.c b/sysdep.c
deleted file mode 100644
index 3c87db2d5c89..000000000000
--- a/sysdep.c
+++ /dev/null
@@ -1,409 +0,0 @@
-/*******************************************************************
-** s y s d e p . c
-** Forth Inspired Command Language
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 16 Oct 1997
-** Implementations of FICL external interface functions...
-**
-** (simple) port to Linux, Skip Carter 26 March 1998
-** $Id: sysdep.c,v 1.9 2001-07-23 22:01:24-07 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** 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
-** 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 <stdlib.h>
-#include <stdio.h>
-
-#include "ficl.h"
-
-/*
-******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
-*/
-#if defined (FREEBSD_ALPHA)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- u_int64_t qx;
-
- qx = (u_int64_t)x * (u_int64_t) y;
-
- q.hi = (u_int32_t)( qx >> 32 );
- q.lo = (u_int32_t)( qx & 0xFFFFFFFFL);
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- u_int64_t qx, qh;
-
- qh = q.hi;
- qx = (qh << 32) | q.lo;
-
- result.quot = qx / y;
- result.rem = qx % y;
-
- return result;
-}
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- while(*msg != 0)
- putchar(*(msg++));
- if (fNewline)
- putchar('\n');
-
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-void *ficlRealloc (void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-/*
-******************* P C / W I N 3 2 P O R T B E G I N S H E R E ***********************
-*/
-#elif defined (_M_IX86)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
-
- __asm
- {
- mov eax,x
- mov edx,y
- mul edx
- mov q.hi,edx
- mov q.lo,eax
- }
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
-
- __asm
- {
- mov eax,q.lo
- mov edx,q.hi
- div y
- mov result.quot,eax
- mov result.rem,edx
- }
-
- return result;
-}
-
-#endif
-
-#if !defined (_WINDOWS)
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- if (fNewline)
- puts(msg);
- else
- fputs(msg, stdout);
-
- return;
-}
-
-#endif
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-
-void *ficlRealloc(void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-/*
-******************* 6 8 K C P U 3 2 P O R T B E G I N S H E R E ********************
-*/
-#elif defined (MOTO_CPU32)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- IGNORE(q); /* suppress goofy compiler warnings */
- IGNORE(x);
- IGNORE(y);
-
-#pragma ASM
- move.l (S_x,a6),d1
- mulu.l (S_y,a6),d0:d1
- move.l d1,(S_q+4,a6)
- move.l d0,(S_q+0,a6)
-#pragma END_ASM
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- IGNORE(result); /* suppress goofy compiler warnings */
- IGNORE(q);
- IGNORE(y);
-
-#pragma ASM
- move.l (S_q+0,a6),d0 ; hi 32 --> d0
- move.l (S_q+4,a6),d1 ; lo 32 --> d1
- divu.l (S_y,a6),d0:d1 ; d0 <-- rem, d1 <-- quot
- move.l d1,(S_result+0,a6)
- move.l d0,(S_result+4,a6)
-#pragma END_ASM
-
- return result;
-}
-
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
-}
-
-void ficlFree (void *p)
-{
-}
-
-
-void *ficlRealloc(void *p, size_t size)
-{
- void *pv = malloc(size);
- if (p)
- {
- memcpy(pv, p, size)
- free(p);
- }
-
- return pv;
-}
-
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-#endif /* MOTO_CPU32 */
-
-/*
-******************* Linux P O R T B E G I N S H E R E ******************** Skip Carter, March 1998
-*/
-
-#if defined(linux) || defined(riscos)
-
-#if PORTABLE_LONGMULDIV == 0
-
-typedef unsigned long long __u64;
-typedef unsigned long __u32;
-
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- __u64 qx;
-
- qx = (__u64)x * (__u64) y;
-
- q.hi = (__u32)( qx >> 32 );
- q.lo = (__u32)( qx & 0xFFFFFFFFL);
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- __u64 qx, qh;
-
- qh = q.hi;
- qx = (qh << 32) | q.lo;
-
- result.quot = qx / y;
- result.rem = qx % y;
-
- return result;
-}
-
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- if (fNewline)
- puts(msg);
- else
- fputs(msg, stdout);
-
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-void *ficlRealloc(void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-#endif /* linux */
-
-
diff --git a/sysdep.h b/sysdep.h
deleted file mode 100644
index 27e55a9a10a4..000000000000
--- a/sysdep.h
+++ /dev/null
@@ -1,465 +0,0 @@
-/*******************************************************************
- s y s d e p . h
-** Forth Inspired Command Language
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 16 Oct 1997
-** Ficl system dependent types and prototypes...
-**
-** Note: Ficl also depends on the use of "assert" when
-** FICL_ROBUST is enabled. This may require some consideration
-** in firmware systems since assert often
-** assumes stderr/stdout.
-** $Id: sysdep.h,v 1.11 2001-11-11 12:25:46-08 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** 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
-** 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.
-*/
-
-#if !defined (__SYSDEP_H__)
-#define __SYSDEP_H__
-
-#include <stddef.h> /* size_t, NULL */
-#include <setjmp.h>
-#include <assert.h>
-
-#if defined(_WIN32)
- #include <stdio.h>
- #ifndef alloca
- #define alloca(x) _alloca(x)
- #endif /* alloca */
- #define fstat _fstat
- #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 */
-#define IGNORE(x) &x
-#endif
-
-/*
-** TRUE and FALSE for C boolean operations, and
-** portable 32 bit types for CELLs
-**
-*/
-#if !defined TRUE
-#define TRUE 1
-#endif
-#if !defined FALSE
-#define FALSE 0
-#endif
-
-/*
-** FreeBSD Alpha (64 bit) data types
-*/
-#if defined (FREEBSD_ALPHA)
-
-#define INT32 int
-#define UNS32 unsigned int
-#define FICL_INT long
-#define FICL_UNS unsigned long
-#define BITS_PER_CELL 64
-#define FICL_ALIGN 3
-#endif
-
-/*
-** System dependent data type declarations...
-*/
-#if !defined INT32
-#define INT32 long
-#endif
-
-#if !defined UNS32
-#define UNS32 unsigned long
-#endif
-
-#if !defined UNS16
-#define UNS16 unsigned short
-#endif
-
-#if !defined UNS8
-#define UNS8 unsigned char
-#endif
-
-#if !defined NULL
-#define NULL ((void *)0)
-#endif
-
-/*
-** FICL_UNS and FICL_INT must have the same size as a void* on
-** the target system. A CELL is a union of void*, FICL_UNS, and
-** FICL_INT.
-** (11/2000: same for FICL_FLOAT)
-*/
-#if !defined FICL_INT
-#define FICL_INT INT32
-#endif
-
-#if !defined FICL_UNS
-#define FICL_UNS UNS32
-#endif
-
-#if !defined FICL_FLOAT
-#define FICL_FLOAT float
-#endif
-
-/*
-** Ficl presently supports values of 32 and 64 for BITS_PER_CELL
-*/
-#if !defined BITS_PER_CELL
-#define BITS_PER_CELL 32
-#endif
-
-#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64))
- Error!
-#endif
-
-typedef struct
-{
- FICL_UNS hi;
- FICL_UNS lo;
-} DPUNS;
-
-typedef struct
-{
- FICL_UNS quot;
- FICL_UNS rem;
-} UNSQR;
-
-typedef struct
-{
- FICL_INT hi;
- FICL_INT lo;
-} DPINT;
-
-typedef struct
-{
- FICL_INT quot;
- FICL_INT rem;
-} INTQR;
-
-
-/*
-** B U I L D C O N T R O L S
-*/
-
-#if !defined (FICL_MINIMAL)
-#define FICL_MINIMAL 0
-#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
-#define FICL_WANT_DEBUGGER 0
-#define FICL_WANT_OOP 0
-#define FICL_PLATFORM_EXTEND 0
-#define FICL_MULTITHREAD 0
-#define FICL_ROBUST 0
-#define FICL_EXTENDED_PREFIX 0
-#endif
-
-/*
-** FICL_PLATFORM_EXTEND
-** Includes words defined in ficlCompilePlatform (see win32.c and unix.c for example)
-*/
-#if defined (_WIN32)
-#if !defined (FICL_PLATFORM_EXTEND)
-#define FICL_PLATFORM_EXTEND 1
-#endif
-#endif
-
-#if !defined (FICL_PLATFORM_EXTEND)
-#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
-*/
-#if !defined (FICL_WANT_FLOAT)
-#define FICL_WANT_FLOAT 1
-#endif
-
-/*
-** FICL_WANT_DEBUGGER
-** Inludes a simple source level debugger
-*/
-#if !defined (FICL_WANT_DEBUGGER)
-#define FICL_WANT_DEBUGGER 1
-#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
-** approach of an array of CELLs instead.
-*/
-#if !defined FICL_WANT_USER
-#define FICL_WANT_USER 1
-#endif
-
-#if !defined FICL_USER_CELLS
-#define FICL_USER_CELLS 16
-#endif
-
-/*
-** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and
-** a private dictionary for local variable compilation.
-*/
-#if !defined FICL_WANT_LOCALS
-#define FICL_WANT_LOCALS 1
-#endif
-
-/* Max number of local variables per definition */
-#if !defined FICL_MAX_LOCALS
-#define FICL_MAX_LOCALS 16
-#endif
-
-/*
-** FICL_WANT_OOP
-** Inludes object oriented programming support (in softwords)
-** OOP support requires locals and user variables!
-*/
-#if !(FICL_WANT_LOCALS) || !(FICL_WANT_USER)
-#if !defined (FICL_WANT_OOP)
-#define FICL_WANT_OOP 0
-#endif
-#endif
-
-#if !defined (FICL_WANT_OOP)
-#define FICL_WANT_OOP 1
-#endif
-
-/*
-** FICL_WANT_SOFTWORDS
-** Controls inclusion of all softwords in softcore.c
-*/
-#if !defined (FICL_WANT_SOFTWORDS)
-#define FICL_WANT_SOFTWORDS 1
-#endif
-
-/*
-** FICL_MULTITHREAD enables dictionary mutual exclusion
-** wia the ficlLockDictionary system dependent function.
-** Note: this implementation is experimental and poorly
-** tested. Further, it's unnecessary unless you really
-** intend to have multiple SESSIONS (poor choice of name
-** on my part) - that is, threads that modify the dictionary
-** at the same time.
-*/
-#if !defined FICL_MULTITHREAD
-#define FICL_MULTITHREAD 0
-#endif
-
-/*
-** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
-** defined in C in sysdep.c. Use this if you cannot easily
-** generate an inline asm definition
-*/
-#if !defined (PORTABLE_LONGMULDIV)
-#define PORTABLE_LONGMULDIV 0
-#endif
-
-/*
-** INLINE_INNER_LOOP causes the inner interpreter to be inline code
-** instead of a function call. This is mainly because MS VC++ 5
-** chokes with an internal compiler error on the function version.
-** in release mode. Sheesh.
-*/
-#if !defined INLINE_INNER_LOOP
-#if defined _DEBUG
-#define INLINE_INNER_LOOP 0
-#else
-#define INLINE_INNER_LOOP 1
-#endif
-#endif
-
-/*
-** FICL_ROBUST enables bounds checking of stacks and the dictionary.
-** This will detect stack over and underflows and dictionary overflows.
-** Any exceptional condition will result in an assertion failure.
-** (As generated by the ANSI assert macro)
-** FICL_ROBUST == 1 --> stack checking in the outer interpreter
-** FICL_ROBUST == 2 also enables checking in many primitives
-*/
-
-#if !defined FICL_ROBUST
-#define FICL_ROBUST 2
-#endif
-
-/*
-** FICL_DEFAULT_STACK Specifies the default size (in CELLs) of
-** a new virtual machine's stacks, unless overridden at
-** create time.
-*/
-#if !defined FICL_DEFAULT_STACK
-#define FICL_DEFAULT_STACK 128
-#endif
-
-/*
-** FICL_DEFAULT_DICT specifies the number of CELLs to allocate
-** for the system dictionary by default. The value
-** can be overridden at startup time as well.
-** FICL_DEFAULT_ENV specifies the number of cells to allot
-** for the environment-query dictionary.
-*/
-#if !defined FICL_DEFAULT_DICT
-#define FICL_DEFAULT_DICT 12288
-#endif
-
-#if !defined FICL_DEFAULT_ENV
-#define FICL_DEFAULT_ENV 512
-#endif
-
-/*
-** FICL_DEFAULT_VOCS specifies the maximum number of wordlists in
-** the dictionary search order. See Forth DPANS sec 16.3.3
-** (file://dpans16.htm#16.3.3)
-*/
-#if !defined FICL_DEFAULT_VOCS
-#define FICL_DEFAULT_VOCS 16
-#endif
-
-/*
-** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure
-** that stores pointers to parser extension functions. I would never expect to have
-** more than 8 of these, so that's the default limit. Too many of these functions
-** will probably exact a nasty performance penalty.
-*/
-#if !defined FICL_MAX_PARSE_STEPS
-#define FICL_MAX_PARSE_STEPS 8
-#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
-** of the target system; 2 is safe on any 16 or 32 bit
-** machine. 3 would be appropriate for a 64 bit machine.
-*/
-#if !defined FICL_ALIGN
-#define FICL_ALIGN 2
-#define FICL_ALIGN_ADD ((1 << FICL_ALIGN) - 1)
-#endif
-
-/*
-** System dependent routines --
-** edit the implementations in sysdep.c to be compatible
-** with your runtime environment...
-** ficlTextOut sends a NULL terminated string to the
-** default output device - used for system error messages
-** ficlMalloc and ficlFree have the same semantics as malloc and free
-** in standard C
-** ficlLongMul multiplies two UNS32s and returns a 64 bit unsigned
-** product
-** ficlLongDiv divides an UNS64 by an UNS32 and returns UNS32 quotient
-** and remainder
-*/
-struct vm;
-void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
-void *ficlMalloc (size_t size);
-void ficlFree (void *p);
-void *ficlRealloc(void *p, size_t size);
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** must be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** before timeout (optional - could also block forever)
-**
-** NOTE: this function must be implemented with lock counting
-** semantics: nested calls must behave properly.
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock);
-#else
-#define ficlLockDictionary(x) 0 /* ignore */
-#endif
-
-/*
-** 64 bit integer math support routines: multiply two UNS32s
-** to get a 64 bit product, & divide the product by an UNS32
-** to get an UNS32 quotient and remainder. Much easier in asm
-** on a 32 bit CPU than in C, which usually doesn't support
-** the double length result (but it should).
-*/
-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__*/
diff --git a/system.c b/system.c
new file mode 100644
index 000000000000..6caff931cf6f
--- /dev/null
+++ b/system.c
@@ -0,0 +1,466 @@
+/*******************************************************************
+** f i c l . c
+** Forth Inspired Command Language - external interface
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+** $Id: system.c,v 1.2 2010/09/10 10:35:54 asau Exp $
+*******************************************************************/
+/*
+** This is an ANS Forth interpreter written in C.
+** Ficl uses Forth syntax for its commands, but turns the Forth
+** model on its head in other respects.
+** Ficl provides facilities for interoperating
+** with programs written in C: C functions can be exported to Ficl,
+** and Ficl commands can be executed via a C calling interface. The
+** interpreter is re-entrant, so it can be used in multiple instances
+** in a multitasking system. Unlike Forth, Ficl's outer interpreter
+** expects a text block as input, and returns to the caller after each
+** text block, so the data pump is somewhere in external code in the
+** style of TCL.
+**
+** Code is written in ANSI C for portability.
+*/
+/*
+** 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
+** 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 <stdlib.h>
+#include <string.h>
+#include "ficl.h"
+
+
+/*
+** System statics
+** Each ficlSystem builds a global dictionary during its start
+** sequence. This is shared by all virtual machines of that system.
+** Therefore only one VM can update the dictionary
+** at a time. The system imports a locking function that
+** you can override in order to control update access to
+** the dictionary. The function is stubbed out by default,
+** but you can insert one: #define FICL_WANT_MULTITHREADED 1
+** and supply your own version of ficlDictionaryLock.
+*/
+
+
+ficlSystem *ficlSystemGlobal = NULL;
+
+/**************************************************************************
+ f i c l S e t V e r s i o n E n v
+** Create a double ficlCell environment constant for the version ID
+**************************************************************************/
+static void ficlSystemSetVersion(ficlSystem *system)
+{
+ int major = 0;
+ int minor = 0;
+ ficl2Integer combined;
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+ sscanf(FICL_VERSION, "%d.%d", &major, &minor);
+ FICL_2INTEGER_SET(major, minor, combined);
+ ficlDictionarySet2Constant(environment, "ficl-version", combined);
+ ficlDictionarySetConstant(environment, "ficl-robust", FICL_ROBUST);
+ return;
+}
+
+
+
+
+
+/**************************************************************************
+ f i c l I n i t S y s t e m
+** Binds a global dictionary to the interpreter system.
+** You specify the address and size of the allocated area.
+** 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.
+** The dictionary needs to be at least large enough to hold the
+** precompiled part. Try 1K cells minimum. Use "words" to find
+** out how much of the dictionary is used at any time.
+**************************************************************************/
+ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi)
+{
+ ficlInteger dictionarySize;
+ ficlInteger environmentSize;
+ ficlInteger stackSize;
+ ficlSystem *system;
+ ficlCallback callback;
+ ficlSystemInformation fauxInfo;
+ ficlDictionary *environment;
+
+
+
+ if (fsi == NULL)
+ {
+ fsi = &fauxInfo;
+ ficlSystemInformationInitialize(fsi);
+ }
+
+ callback.context = fsi->context;
+ callback.textOut = fsi->textOut;
+ callback.errorOut = fsi->errorOut;
+ callback.system = NULL;
+ callback.vm = NULL;
+
+ FICL_ASSERT(&callback, sizeof(ficlInteger) >= sizeof(void *));
+ FICL_ASSERT(&callback, sizeof(ficlUnsigned) >= sizeof(void *));
+#if (FICL_WANT_FLOAT)
+ FICL_ASSERT(&callback, sizeof(ficlFloat) <= sizeof(ficlInteger));
+#endif
+
+ system = ficlMalloc(sizeof(ficlSystem));
+
+ FICL_ASSERT(&callback, system);
+
+ memset(system, 0, sizeof(ficlSystem));
+
+ dictionarySize = fsi->dictionarySize;
+ if (dictionarySize <= 0)
+ dictionarySize = FICL_DEFAULT_DICTIONARY_SIZE;
+
+ environmentSize = fsi->environmentSize;
+ if (environmentSize <= 0)
+ environmentSize = FICL_DEFAULT_DICTIONARY_SIZE;
+
+ stackSize = fsi->stackSize;
+ if (stackSize < FICL_DEFAULT_STACK_SIZE)
+ stackSize = FICL_DEFAULT_STACK_SIZE;
+
+ system->dictionary = ficlDictionaryCreateHashed(system, (unsigned)dictionarySize, FICL_HASH_SIZE);
+ system->dictionary->forthWordlist->name = "forth-wordlist";
+
+ environment = ficlDictionaryCreate(system, (unsigned)environmentSize);
+ system->environment = environment;
+ system->environment->forthWordlist->name = "environment";
+
+ system->callback.textOut = fsi->textOut;
+ system->callback.errorOut = fsi->errorOut;
+ system->callback.context = fsi->context;
+ system->callback.system = system;
+ system->callback.vm = NULL;
+ system->stackSize = stackSize;
+
+#if FICL_WANT_LOCALS
+ /*
+ ** The locals dictionary is only searched while compiling,
+ ** but this is where speed is most important. On the other
+ ** hand, the dictionary gets emptied after each use of locals
+ ** The need to balance search speed with the cost of the 'empty'
+ ** operation led me to select a single-threaded list...
+ */
+ system->locals = ficlDictionaryCreate(system, (unsigned)FICL_MAX_LOCALS * FICL_CELLS_PER_WORD);
+#endif /* FICL_WANT_LOCALS */
+
+ /*
+ ** 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.
+ */
+ ficlSystemCompileCore(system);
+ ficlSystemCompilePrefix(system);
+
+#if FICL_WANT_FLOAT
+ ficlSystemCompileFloat(system);
+#endif /* FICL_WANT_FLOAT */
+
+#if FICL_WANT_PLATFORM
+ ficlSystemCompilePlatform(system);
+#endif /* FICL_WANT_PLATFORM */
+
+ ficlSystemSetVersion(system);
+
+ /*
+ ** Establish the parse order. Note that prefixes precede numbers -
+ ** this allows constructs like "0b101010" which might parse as a
+ ** hex value otherwise.
+ */
+ ficlSystemAddPrimitiveParseStep(system, "?word", ficlVmParseWord);
+ ficlSystemAddPrimitiveParseStep(system, "?prefix", ficlVmParsePrefix);
+ ficlSystemAddPrimitiveParseStep(system, "?number", ficlVmParseNumber);
+#if FICL_WANT_FLOAT
+ ficlSystemAddPrimitiveParseStep(system, "?float", ficlVmParseFloatNumber);
+#endif
+
+ /*
+ ** Now create a temporary VM to compile the softwords. Since all VMs are
+ ** linked into the vmList of ficlSystem, we don't have to pass the VM
+ ** to ficlCompileSoftCore -- it just hijacks whatever it finds in the VM list.
+ ** Ficl 2.05: vmCreate no longer depends on the presence of INTERPRET in the
+ ** dictionary, so a VM can be created before the dictionary is built. It just
+ ** can't do much...
+ */
+ ficlSystemCreateVm(system);
+#define ADD_COMPILE_FLAG(name) ficlDictionarySetConstant(environment, #name, name)
+ ADD_COMPILE_FLAG(FICL_WANT_LZ_SOFTCORE);
+ ADD_COMPILE_FLAG(FICL_WANT_FILE);
+ ADD_COMPILE_FLAG(FICL_WANT_FLOAT);
+ ADD_COMPILE_FLAG(FICL_WANT_DEBUGGER);
+ ADD_COMPILE_FLAG(FICL_WANT_EXTENDED_PREFIX);
+ ADD_COMPILE_FLAG(FICL_WANT_USER);
+ ADD_COMPILE_FLAG(FICL_WANT_LOCALS);
+ ADD_COMPILE_FLAG(FICL_WANT_OOP);
+ ADD_COMPILE_FLAG(FICL_WANT_SOFTWORDS);
+ ADD_COMPILE_FLAG(FICL_WANT_MULTITHREADED);
+ ADD_COMPILE_FLAG(FICL_WANT_OPTIMIZE);
+ ADD_COMPILE_FLAG(FICL_WANT_VCALL);
+
+ ADD_COMPILE_FLAG(FICL_PLATFORM_ALIGNMENT);
+
+ ADD_COMPILE_FLAG(FICL_ROBUST);
+
+#define ADD_COMPILE_STRING(name) ficlDictionarySetConstantString(environment, #name, name)
+ ADD_COMPILE_STRING(FICL_PLATFORM_ARCHITECTURE);
+ ADD_COMPILE_STRING(FICL_PLATFORM_OS);
+
+ ficlSystemCompileSoftCore(system);
+ ficlSystemDestroyVm(system->vmList);
+
+ if (ficlSystemGlobal == NULL)
+ ficlSystemGlobal = system;
+
+ return system;
+}
+
+
+
+/**************************************************************************
+ f i c l T e r m S y s t e m
+** Tear the system down by deleting the dictionaries and all VMs.
+** This saves you from having to keep track of all that stuff.
+**************************************************************************/
+void ficlSystemDestroy(ficlSystem *system)
+{
+ if (system->dictionary)
+ ficlDictionaryDestroy(system->dictionary);
+ system->dictionary = NULL;
+
+ if (system->environment)
+ ficlDictionaryDestroy(system->environment);
+ system->environment = NULL;
+
+#if FICL_WANT_LOCALS
+ if (system->locals)
+ ficlDictionaryDestroy(system->locals);
+ system->locals = NULL;
+#endif
+
+ while (system->vmList != NULL)
+ {
+ ficlVm *vm = system->vmList;
+ system->vmList = system->vmList->link;
+ ficlVmDestroy(vm);
+ }
+
+ ficlFree(system);
+ system = NULL;
+
+ if (ficlSystemGlobal == system)
+ ficlSystemGlobal = NULL;
+
+ return;
+}
+
+
+/**************************************************************************
+ 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
+** ficlParseStep notes in ficl.h for details). Returns 0 if successful,
+** nonzero if there's no more room in the list.
+**************************************************************************/
+int ficlSystemAddParseStep(ficlSystem *system, ficlWord *word)
+{
+ int i;
+ for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
+ {
+ if (system->parseList[i] == NULL)
+ {
+ system->parseList[i] = word;
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+
+/*
+** Compile a word into the dictionary that invokes the specified ficlParseStep
+** function. It is up to the user (as usual in Forth) to make sure the stack
+** preconditions are valid (there needs to be a counted string on top of the stack)
+** before using the resulting word.
+*/
+void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep pStep)
+{
+ ficlDictionary *dictionary = system->dictionary;
+ ficlWord *word = ficlDictionaryAppendPrimitive(dictionary, name, ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(pStep));
+ ficlSystemAddParseStep(system, word);
+}
+/**************************************************************************
+ f i c l N e w V M
+** Create a new virtual machine and link it into the system list
+** of VMs for later cleanup by ficlTermSystem.
+**************************************************************************/
+ficlVm *ficlSystemCreateVm(ficlSystem *system)
+{
+ ficlVm *vm = ficlVmCreate(NULL, system->stackSize, system->stackSize);
+ vm->link = system->vmList;
+
+ memcpy(&(vm->callback), &(system->callback), sizeof(system->callback));
+ vm->callback.vm = vm;
+ vm->callback.system = system;
+
+ system->vmList = vm;
+ return vm;
+}
+
+
+/**************************************************************************
+ f i c l F r e e V M
+** Removes the VM in question from the system VM list and deletes the
+** memory allocated to it. This is an optional call, since ficlTermSystem
+** will do this cleanup for you. This function is handy if you're going to
+** do a lot of dynamic creation of VMs.
+**************************************************************************/
+void ficlSystemDestroyVm(ficlVm *vm)
+{
+ ficlSystem *system = vm->callback.system;
+ ficlVm *pList = system->vmList;
+
+ FICL_VM_ASSERT(vm, vm != NULL);
+
+ if (system->vmList == vm)
+ {
+ system->vmList = system->vmList->link;
+ }
+ else for (; pList != NULL; pList = pList->link)
+ {
+ if (pList->link == vm)
+ {
+ pList->link = vm->link;
+ break;
+ }
+ }
+
+ if (pList)
+ ficlVmDestroy(vm);
+ return;
+}
+
+
+/**************************************************************************
+ f i c l L o o k u p
+** Look in the system dictionary for a match to the given name. If
+** found, return the address of the corresponding ficlWord. Otherwise
+** return NULL.
+**************************************************************************/
+ficlWord *ficlSystemLookup(ficlSystem *system, char *name)
+{
+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryLookup(system->dictionary, s);
+}
+
+
+/**************************************************************************
+ f i c l G e t D i c t
+** Returns the address of the system dictionary
+**************************************************************************/
+ficlDictionary *ficlSystemGetDictionary(ficlSystem *system)
+{
+ return system->dictionary;
+}
+
+
+/**************************************************************************
+ f i c l G e t E n v
+** Returns the address of the system environment space
+**************************************************************************/
+ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system)
+{
+ return system->environment;
+}
+
+
+/**************************************************************************
+ f i c l G e t L o c
+** Returns the address of the system locals dictionary. This dictionary is
+** only used during compilation, and is shared by all VMs.
+**************************************************************************/
+#if FICL_WANT_LOCALS
+ficlDictionary *ficlSystemGetLocals(ficlSystem *system)
+{
+ return system->locals;
+}
+#endif
+
+
+
+/**************************************************************************
+ f i c l L o o k u p L o c
+** Same as dictLookup, but looks in system locals dictionary first...
+** Assumes locals dictionary has only one wordlist...
+**************************************************************************/
+#if FICL_WANT_LOCALS
+ficlWord *ficlSystemLookupLocal(ficlSystem *system, ficlString name)
+{
+ ficlWord *word = NULL;
+ ficlDictionary *dictionary = system->dictionary;
+ ficlHash *hash = ficlSystemGetLocals(system)->forthWordlist;
+ int i;
+ ficlUnsigned16 hashCode = ficlHashCode(name);
+
+ FICL_SYSTEM_ASSERT(system, hash);
+ FICL_SYSTEM_ASSERT(system, dictionary);
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ /*
+ ** check the locals dictionary first...
+ */
+ word = ficlHashLookup(hash, name, hashCode);
+
+ /*
+ ** If no joy, (!word) ------------------------------v
+ ** iterate over the search list in the main dictionary
+ */
+ for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i)
+ {
+ hash = dictionary->wordlists[i];
+ word = ficlHashLookup(hash, name, hashCode);
+ }
+
+ ficlDictionaryLock(dictionary, FICL_FALSE);
+ return word;
+}
+#endif
+
+
diff --git a/test/asm68k.4th b/test/asm68k.4th
index a549d69c17c6..fdfb8495fd48 100644
--- a/test/asm68k.4th
+++ b/test/asm68k.4th
@@ -1,308 +1,300 @@
-HEX
-4e71 constant nop
-
-\ w, ( WORD compile )
-: w, ( d16 -- ) dup 100 / c, c, ;
-
-: OCTAL 8 BASE ! ;
-
-
-\ FORTH ASSEMBLER ....
-
-ALSO FORTH
-VOCABULARY ASSEMBLER IMMEDIATE
-ASSEMBLER DEFINITIONS
-
-: END-CODE ALIGN CURRENT @ CONTEXT ! ;
-: *SWAP SWAP ;
-: ?, IF w, THEN w, ;
-
-\ SIZES
-
-OCTAL
-VARIABLE SIZE
-: BYTE 10000 SIZE ! ;
-: WORD 30100 SIZE ! ;
-: LONG 24600 SIZE ! ;
-: SZ CREATE , DOES> @ SIZE @ AND OR ;
-
-00300 SZ SZ3
-00400 SZ SZ4
-04000 SZ SZ40
-30000 SZ SZ300
-
-: LONG? SIZE @ 24600 = ;
-: -SZ1 LONG? IF 100 OR THEN ;
-
-\ ADDRESSING MODES
-
-: REGS 10 0 DO DUP 1001 I * OR CONSTANT LOOP DROP ;
-: MODE CREATE , DOES> @ SWAP 7007 AND OR ;
-
-0000 REGS D0 D1 D2 D3 D4 D5 D6 D7
-0110 REGS A0 A1 A2 A3 A4 A5 A6 A7
-
-0220 MODE )
-0330 MODE )+
-0440 MODE -)
-0550 MODE D)
-0660 MODE DI)
-0770 CONSTANT #)
-1771 CONSTANT L#)
-2772 CONSTANT PCD)
-3773 CONSTANT PCDI)
-4774 CONSTANT #
-
-\ FIELDS AND REGISTER ASSIGNMENTS
-
-: FIELD CREATE , DOES> @ AND ;
-
-7000 FIELD RD
-0007 FIELD RS
-0070 FIELD MS
-0077 FIELD EAS
-0377 FIELD LOW
-
-: DN? DUP MS 0 = ;
-: SRC OVER EAS OR ;
-: DST SWAP RD OR ;
-
-A7 CONSTANT SP
-A6 CONSTANT RP
-A5 CONSTANT IP
-
-: ?MODE 0 = ABORT" BAD MODE" ;
-: ??Dn DN? ?MODE ;
-: ??An DUP MS 1 = ?MODE ;
-: ??JMP DUP MS DUP 2 = SWAP 4 > OR OVER 74 = NOT AND ?MODE ;
-
-\ EXTENDED ADDRESSING
-
-: DOUBLE? DUP L#) = SWAP # = LONG? AND OR ;
-: INDEX?
- DUP >R DUP 0770 AND A0 DI) = SWAP PCDI) = OR
- IF DUP RD 10 * SWAP MS IF 100000 OR THEN
- SZ40 SWAP LOW OR
- THEN R> ;
-: MORE? DUP MS 0040 > ;
-: ,MORE MORE? IF INDEX? DOUBLE? ?, ELSE DROP THEN ;
-
-\ EXTENDED ADDRESSING EXTRAS
-
-CREATE EXTRA HERE 10 ALLOT 10 ERASE
-
-: EXTRA? MORE?
- IF >R R@ INDEX? DOUBLE? EXTRA 1 + SWAP
- IF 2! 2 ELSE ! 1 THEN EXTRA C! R>
- ELSE 0 EXTRA ! THEN ;
-: ,EXTRA EXTRA C@ ?DUP
- IF EXTRA 1 + SWAP 1 =
- IF @ w, ELSE 2@ , THEN EXTRA 10 ERASE
- THEN ;
-
-\ IMMEDIATE & ADDRESS REGISTER SPECIFIC INSTRUCTIONS
-
-: IMM CREATE , DOES> @ >R EXTRA? EAS R> OR SZ3 w, LONG? ?, ,EXTRA ;
-0000 IMM ORI
-1000 IMM ANDI
-2000 IMM SUBI
-3000 IMM ADDI
-5000 IMM EORI
-6000 IMM CMPI
-
-: IMMSR CREATE , DOES> @ SZ3 , ;
-001074 IMMSR ANDI>SR
-005074 IMMSR EORI>SR
-000074 IMMSR ORI>SR
-
-: IQ CREATE , DOES> @ >R EXTRA? EAS SWAP RS 1000 * OR R> OR SZ3 w, ,EXTRA ;
-050000 IQ ADDQ
-050400 IQ SUBQ
-
-: IEAA CREATE , DOES> @ DST SRC SZ4 w, ,MORE ;
-150300 IEAA ADDA
-130300 IEAA CMPA
-040700 IEAA LEA
-110300 IEAA SUBA
-
-\ SHIFTS, ROTATES, & BIT MANIPULATION
-: ISR CREATE , DOES> @ >R DN?
- IF SWAP DN? IF R> 40 OR >R ELSE DROP SWAP 1000 * THEN
- RD SWAP RS OR R> OR 160000 OR SZ3 w,
- ELSE DUP EAS 300 OR R@ 400 AND OR R> 70 AND 100 * OR
- 160000 OR w, ,MORE
- THEN ;
-400 ISR ASL
-000 ISR ASR
-410 ISR LSL
-010 ISR LSR
-420 ISR ROXL
-020 ISR ROXR
-430 ISR ROL
-030 ISR ROR
-
-: IBIT CREATE , DOES> @ >R EXTRA? DN?
- IF RD SRC 400 ELSE DROP DUP EAS 4000 THEN
- OR R> OR w, ,EXTRA ,MORE ;
-000 IBIT BTST
-100 IBIT BCHG
-200 IBIT BCLR
-300 IBIT BSET
-
-\ BRANCH, LOOP, & SET CONDITIONALS
-
-: SETCLASS ' SWAP 0 DO I OVER EXECUTE LOOP DROP ;
-: SETCLAS2 ' ROT ROT DO I OVER EXECUTE LOOP DROP ;
-: IBRA 400 * 060000 OR CREATE ,
- DOES> @ SWAP HERE 2 + - DUP ABS 200 <
- IF LOW OR w, ELSE SWAP , THEN ;
-: IDBR 400 * 050310 OR CREATE ,
- DOES> @ SWAP RS OR w, HERE - , ;
-: ISET 400 * 050300 OR CREATE ,
- DOES> @ SRC w, ,MORE ;
-
-20 SETCLASS IBRA BRA BSR BHI BLS BCC BCS BNE BEQ BVC BVS BPL BMI BGE BLT BGT BLE
-
-10 SETCLASS IDBR DXIT DBRA DBHI DBLS DBCC DBCS DBNE DBEQ
-
-20 10 SETCLAS2 IDBR DBVC DBVS DBPL DBMI DBGE DBLT DBGT DBLE
-
-20 SETCLASS ISET SET SNO SHI SLS SCC SCS SNE SEQ SVC SVS SPL SMI SGE SLT SGT SLE
-
-\ MOVES
-
-: MOVE EXTRA? 7700 AND SRC SZ300 w, ,MORE ,EXTRA ;
-
-: MOVEQ RD SWAP LOW OR 070000 OR w, ;
-
-: MOVE>USP RS 047140 OR w, ;
-: MOVE<USP RS 047150 OR w, ;
-: MOVEM> EXTRA? EAS 044200 OR -SZ1 w, w, ,EXTRA ;
-: MOVEM< EXTRA? EAS 046200 OR -SZ1 w, w, ,EXTRA ;
-: MOVEP DN? IF RD SWAP RS OR 410 OR
- ELSE RS ROT RD OR 610 OR
- THEN -SZ1 , ;
-: LMOVE 7700 AND SWAP EAS OR 20000 OR w, ;
-
-\ ODDS AND ENDS
-
-: CMPM RD SWAP RS OR 130410 OR SZ3 w, ;
-: EXG
- DN? IF SWAP DN? IF 140500 ELSE 140610 THEN >R
- ELSE SWAP DN? IF 140610 ELSE 140510 THEN >R SWAP
- THEN RS DST R> OR w, ;
-: EXT RS 044200 OR -SZ1 w, ;
-: SWAP RS 044100 OR w, ;
-: STOP 47162 , ;
-: TRAP 17 AND 47100 OR w, ;
-: LINK RS 047120 OR , ;
-: UNLK RS 047130 OR w, ;
-
-\ ARITHMETIC & LOGIC
-
-: EOR EXTRA? EAS DST SZ3 130400 OR w, ,EXTRA ;
-
-: IDD CREATE ,
- DOES> @ DST OVER RS OR *SWAP MS IF 10 OR THEN w, ;
-
-140400 IDD ABCD
-100400 IDD SBCD
-150300 IDD ADDX
-110400 IDD SUBX
-
-: IDEA CREATE ,
- DOES> @ >R DN?
- IF RD SRC R> OR SZ3 w, ,MORE
- ELSE EXTRA? EAS DST 400 OR R> OR SZ3 w, ,EXTRA THEN ;
-
-150000 IDEA ADD
-110000 IDEA SUB
-140000 IDEA AND
-100000 IDEA OR
-
-: IEAD CREATE , DOES> @ DST SRC w, ,MORE ;
-
-040600 IEAD CHK
-100300 IEAD DIVU
-100700 IEAD DIVS
-140300 IEAD MULU
-140700 IEAD MULS
-
-: CMP 130000 DST SRC SZ3 w, ,MORE ;
-
-\ ARITHMETIC & CONTROL
-
-
-: IEA CREATE , DOES> @ SRC w, ,MORE ;
-
-047200 IEA JSR
-047300 IEA JMP
-042300 IEA MOVE>CCR
-040300 IEA MOVE<SR
-043300 IEA MOVE>SR
-044000 IEA NBCD
-044100 IEA PEA
-045300 IEA TAS
-
-: IEAS CREATE , DOES> @ SRC SZ3 w, ,MORE ;
-
-041000 IEAS CLR
-043000 IEAS NOT
-042000 IEAS NEG
-040000 IEAS NEGX
-045000 IEAS TST
-
-: ICON CREATE , DOES> @ w, ;
-
-47160 ICON RESET
-47161 ICON NOP
-47163 ICON RTE
-47165 ICON RTS
-47166 ICON TRAPV
-47167 ICON RTR
-
-\ STRUCTURED CONDITIONALS ( +/- 256 BYTES )
-
-: THEN HERE OVER 2 + - *SWAP 1 + C! ;
-: ENDIF THEN ;
-: IF w, HERE 2 - ;
-
-HEX
-
-: ELSE 6000 IF *SWAP THEN ;
-: BEGIN HERE ;
-: UNTIL , HERE - HERE 1 - C! ;
-: AGAIN 6000 UNTIL ;
-: WHILE IF ;
-: REPEAT *SWAP AGAIN THEN ;
-: DO HERE *SWAP ;
-: LOOP DBRA ;
-
-6600 CONSTANT 0=
-6700 CONSTANT 0<>
-6A00 CONSTANT 0<
-6B00 CONSTANT 0>=
-6C00 CONSTANT <
-6D00 CONSTANT >=
-6E00 CONSTANT <=
-6F00 CONSTANT >
-
-DECIMAL
-
-: NEXT
- A5 )+ A0 LMOVE
- A0 ) JMP ;
-
-FORTH DEFINITIONS
-
-: LABEL CREATE [COMPILE] ASSEMBLER ASSEMBLER WORD ;
-: CODE LABEL HERE CELL- CELL- CELL- CP ! ;
-
-
-
-
---openmail-part-01d4752f-00000002--
-
---openmail-part-01d4752f-00000001--
-
-
+HEX
+4e71 constant nop
+
+\ w, ( WORD compile )
+: w, ( d16 -- ) dup 100 / c, c, ;
+
+: OCTAL 8 BASE ! ;
+
+
+\ FORTH ASSEMBLER ....
+
+ALSO FORTH
+VOCABULARY ASSEMBLER IMMEDIATE
+ASSEMBLER DEFINITIONS
+
+: END-CODE ALIGN CURRENT @ CONTEXT ! ;
+: *SWAP SWAP ;
+: ?, IF w, THEN w, ;
+
+\ SIZES
+
+OCTAL
+VARIABLE SIZE
+: BYTE 10000 SIZE ! ;
+: WORD 30100 SIZE ! ;
+: LONG 24600 SIZE ! ;
+: SZ CREATE , DOES> @ SIZE @ AND OR ;
+
+00300 SZ SZ3
+00400 SZ SZ4
+04000 SZ SZ40
+30000 SZ SZ300
+
+: LONG? SIZE @ 24600 = ;
+: -SZ1 LONG? IF 100 OR THEN ;
+
+\ ADDRESSING MODES
+
+: REGS 10 0 DO DUP 1001 I * OR CONSTANT LOOP DROP ;
+: MODE CREATE , DOES> @ SWAP 7007 AND OR ;
+
+0000 REGS D0 D1 D2 D3 D4 D5 D6 D7
+0110 REGS A0 A1 A2 A3 A4 A5 A6 A7
+
+0220 MODE )
+0330 MODE )+
+0440 MODE -)
+0550 MODE D)
+0660 MODE DI)
+0770 CONSTANT #)
+1771 CONSTANT L#)
+2772 CONSTANT PCD)
+3773 CONSTANT PCDI)
+4774 CONSTANT #
+
+\ FIELDS AND REGISTER ASSIGNMENTS
+
+: FIELD CREATE , DOES> @ AND ;
+
+7000 FIELD RD
+0007 FIELD RS
+0070 FIELD MS
+0077 FIELD EAS
+0377 FIELD LOW
+
+: DN? DUP MS 0 = ;
+: SRC OVER EAS OR ;
+: DST SWAP RD OR ;
+
+A7 CONSTANT SP
+A6 CONSTANT RP
+A5 CONSTANT IP
+
+: ?MODE 0 = ABORT" BAD MODE" ;
+: ??Dn DN? ?MODE ;
+: ??An DUP MS 1 = ?MODE ;
+: ??JMP DUP MS DUP 2 = SWAP 4 > OR OVER 74 = NOT AND ?MODE ;
+
+\ EXTENDED ADDRESSING
+
+: DOUBLE? DUP L#) = SWAP # = LONG? AND OR ;
+: INDEX?
+ DUP >R DUP 0770 AND A0 DI) = SWAP PCDI) = OR
+ IF DUP RD 10 * SWAP MS IF 100000 OR THEN
+ SZ40 SWAP LOW OR
+ THEN R> ;
+: MORE? DUP MS 0040 > ;
+: ,MORE MORE? IF INDEX? DOUBLE? ?, ELSE DROP THEN ;
+
+\ EXTENDED ADDRESSING EXTRAS
+
+CREATE EXTRA HERE 10 ALLOT 10 ERASE
+
+: EXTRA? MORE?
+ IF >R R@ INDEX? DOUBLE? EXTRA 1 + SWAP
+ IF 2! 2 ELSE ! 1 THEN EXTRA C! R>
+ ELSE 0 EXTRA ! THEN ;
+: ,EXTRA EXTRA C@ ?DUP
+ IF EXTRA 1 + SWAP 1 =
+ IF @ w, ELSE 2@ , THEN EXTRA 10 ERASE
+ THEN ;
+
+\ IMMEDIATE & ADDRESS REGISTER SPECIFIC INSTRUCTIONS
+
+: IMM CREATE , DOES> @ >R EXTRA? EAS R> OR SZ3 w, LONG? ?, ,EXTRA ;
+0000 IMM ORI
+1000 IMM ANDI
+2000 IMM SUBI
+3000 IMM ADDI
+5000 IMM EORI
+6000 IMM CMPI
+
+: IMMSR CREATE , DOES> @ SZ3 , ;
+001074 IMMSR ANDI>SR
+005074 IMMSR EORI>SR
+000074 IMMSR ORI>SR
+
+: IQ CREATE , DOES> @ >R EXTRA? EAS SWAP RS 1000 * OR R> OR SZ3 w, ,EXTRA ;
+050000 IQ ADDQ
+050400 IQ SUBQ
+
+: IEAA CREATE , DOES> @ DST SRC SZ4 w, ,MORE ;
+150300 IEAA ADDA
+130300 IEAA CMPA
+040700 IEAA LEA
+110300 IEAA SUBA
+
+\ SHIFTS, ROTATES, & BIT MANIPULATION
+: ISR CREATE , DOES> @ >R DN?
+ IF SWAP DN? IF R> 40 OR >R ELSE DROP SWAP 1000 * THEN
+ RD SWAP RS OR R> OR 160000 OR SZ3 w,
+ ELSE DUP EAS 300 OR R@ 400 AND OR R> 70 AND 100 * OR
+ 160000 OR w, ,MORE
+ THEN ;
+400 ISR ASL
+000 ISR ASR
+410 ISR LSL
+010 ISR LSR
+420 ISR ROXL
+020 ISR ROXR
+430 ISR ROL
+030 ISR ROR
+
+: IBIT CREATE , DOES> @ >R EXTRA? DN?
+ IF RD SRC 400 ELSE DROP DUP EAS 4000 THEN
+ OR R> OR w, ,EXTRA ,MORE ;
+000 IBIT BTST
+100 IBIT BCHG
+200 IBIT BCLR
+300 IBIT BSET
+
+\ BRANCH, LOOP, & SET CONDITIONALS
+
+: SETCLASS ' SWAP 0 DO I OVER EXECUTE LOOP DROP ;
+: SETCLAS2 ' ROT ROT DO I OVER EXECUTE LOOP DROP ;
+: IBRA 400 * 060000 OR CREATE ,
+ DOES> @ SWAP HERE 2 + - DUP ABS 200 <
+ IF LOW OR w, ELSE SWAP , THEN ;
+: IDBR 400 * 050310 OR CREATE ,
+ DOES> @ SWAP RS OR w, HERE - , ;
+: ISET 400 * 050300 OR CREATE ,
+ DOES> @ SRC w, ,MORE ;
+
+20 SETCLASS IBRA BRA BSR BHI BLS BCC BCS BNE BEQ BVC BVS BPL BMI BGE BLT BGT BLE
+
+10 SETCLASS IDBR DXIT DBRA DBHI DBLS DBCC DBCS DBNE DBEQ
+
+20 10 SETCLAS2 IDBR DBVC DBVS DBPL DBMI DBGE DBLT DBGT DBLE
+
+20 SETCLASS ISET SET SNO SHI SLS SCC SCS SNE SEQ SVC SVS SPL SMI SGE SLT SGT SLE
+
+\ MOVES
+
+: MOVE EXTRA? 7700 AND SRC SZ300 w, ,MORE ,EXTRA ;
+
+: MOVEQ RD SWAP LOW OR 070000 OR w, ;
+
+: MOVE>USP RS 047140 OR w, ;
+: MOVE<USP RS 047150 OR w, ;
+: MOVEM> EXTRA? EAS 044200 OR -SZ1 w, w, ,EXTRA ;
+: MOVEM< EXTRA? EAS 046200 OR -SZ1 w, w, ,EXTRA ;
+: MOVEP DN? IF RD SWAP RS OR 410 OR
+ ELSE RS ROT RD OR 610 OR
+ THEN -SZ1 , ;
+: LMOVE 7700 AND SWAP EAS OR 20000 OR w, ;
+
+\ ODDS AND ENDS
+
+: CMPM RD SWAP RS OR 130410 OR SZ3 w, ;
+: EXG
+ DN? IF SWAP DN? IF 140500 ELSE 140610 THEN >R
+ ELSE SWAP DN? IF 140610 ELSE 140510 THEN >R SWAP
+ THEN RS DST R> OR w, ;
+: EXT RS 044200 OR -SZ1 w, ;
+: SWAP RS 044100 OR w, ;
+: STOP 47162 , ;
+: TRAP 17 AND 47100 OR w, ;
+: LINK RS 047120 OR , ;
+: UNLK RS 047130 OR w, ;
+
+\ ARITHMETIC & LOGIC
+
+: EOR EXTRA? EAS DST SZ3 130400 OR w, ,EXTRA ;
+
+: IDD CREATE ,
+ DOES> @ DST OVER RS OR *SWAP MS IF 10 OR THEN w, ;
+
+140400 IDD ABCD
+100400 IDD SBCD
+150300 IDD ADDX
+110400 IDD SUBX
+
+: IDEA CREATE ,
+ DOES> @ >R DN?
+ IF RD SRC R> OR SZ3 w, ,MORE
+ ELSE EXTRA? EAS DST 400 OR R> OR SZ3 w, ,EXTRA THEN ;
+
+150000 IDEA ADD
+110000 IDEA SUB
+140000 IDEA AND
+100000 IDEA OR
+
+: IEAD CREATE , DOES> @ DST SRC w, ,MORE ;
+
+040600 IEAD CHK
+100300 IEAD DIVU
+100700 IEAD DIVS
+140300 IEAD MULU
+140700 IEAD MULS
+
+: CMP 130000 DST SRC SZ3 w, ,MORE ;
+
+\ ARITHMETIC & CONTROL
+
+
+: IEA CREATE , DOES> @ SRC w, ,MORE ;
+
+047200 IEA JSR
+047300 IEA JMP
+042300 IEA MOVE>CCR
+040300 IEA MOVE<SR
+043300 IEA MOVE>SR
+044000 IEA NBCD
+044100 IEA PEA
+045300 IEA TAS
+
+: IEAS CREATE , DOES> @ SRC SZ3 w, ,MORE ;
+
+041000 IEAS CLR
+043000 IEAS NOT
+042000 IEAS NEG
+040000 IEAS NEGX
+045000 IEAS TST
+
+: ICON CREATE , DOES> @ w, ;
+
+47160 ICON RESET
+47161 ICON NOP
+47163 ICON RTE
+47165 ICON RTS
+47166 ICON TRAPV
+47167 ICON RTR
+
+\ STRUCTURED CONDITIONALS ( +/- 256 BYTES )
+
+: THEN HERE OVER 2 + - *SWAP 1 + C! ;
+: ENDIF THEN ;
+: IF w, HERE 2 - ;
+
+HEX
+
+: ELSE 6000 IF *SWAP THEN ;
+: BEGIN HERE ;
+: UNTIL , HERE - HERE 1 - C! ;
+: AGAIN 6000 UNTIL ;
+: WHILE IF ;
+: REPEAT *SWAP AGAIN THEN ;
+: DO HERE *SWAP ;
+: LOOP DBRA ;
+
+6600 CONSTANT 0=
+6700 CONSTANT 0<>
+6A00 CONSTANT 0<
+6B00 CONSTANT 0>=
+6C00 CONSTANT <
+6D00 CONSTANT >=
+6E00 CONSTANT <=
+6F00 CONSTANT >
+
+DECIMAL
+
+: NEXT
+ A5 )+ A0 LMOVE
+ A0 ) JMP ;
+
+FORTH DEFINITIONS
+
+: LABEL CREATE [COMPILE] ASSEMBLER ASSEMBLER WORD ;
+: CODE LABEL HERE CELL- CELL- CELL- CP ! ;
+
diff --git a/test/core.fr b/test/core.fr
index 39bc181c1203..8d14cbd64c1e 100644
--- a/test/core.fr
+++ b/test/core.fr
@@ -1,997 +1,997 @@
-\ From: John Hayes S1I
-\ Subject: core.fr
-\ Date: Mon, 27 Nov 95 13:10
-
-\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
-\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
-\ VERSION 1.2
-\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
-\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
-\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
-\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
-\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
-\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
-
-TESTING CORE WORDS
-HEX
-
-\ ------------------------------------------------------------------------
-TESTING BASIC ASSUMPTIONS
-
-{ -> } \ START WITH CLEAN SLATE
-( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
-{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
-{ 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR )
-{ 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT )
-{ -1 BITSSET? -> 0 0 }
-
-\ ------------------------------------------------------------------------
-TESTING BOOLEANS: INVERT AND OR XOR
-
-{ 0 0 AND -> 0 }
-{ 0 1 AND -> 0 }
-{ 1 0 AND -> 0 }
-{ 1 1 AND -> 1 }
-
-{ 0 INVERT 1 AND -> 1 }
-{ 1 INVERT 1 AND -> 0 }
-
-0 CONSTANT 0S
-0 INVERT CONSTANT 1S
-
-{ 0S INVERT -> 1S }
-{ 1S INVERT -> 0S }
-
-{ 0S 0S AND -> 0S }
-{ 0S 1S AND -> 0S }
-{ 1S 0S AND -> 0S }
-{ 1S 1S AND -> 1S }
-
-{ 0S 0S OR -> 0S }
-{ 0S 1S OR -> 1S }
-{ 1S 0S OR -> 1S }
-{ 1S 1S OR -> 1S }
-
-{ 0S 0S XOR -> 0S }
-{ 0S 1S XOR -> 1S }
-{ 1S 0S XOR -> 1S }
-{ 1S 1S XOR -> 0S }
-
-\ ------------------------------------------------------------------------
-TESTING 2* 2/ LSHIFT RSHIFT
-
-( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
-1S 1 RSHIFT INVERT CONSTANT MSB
-{ MSB BITSSET? -> 0 0 }
-
-{ 0S 2* -> 0S }
-{ 1 2* -> 2 }
-{ 4000 2* -> 8000 }
-{ 1S 2* 1 XOR -> 1S }
-{ MSB 2* -> 0S }
-
-{ 0S 2/ -> 0S }
-{ 1 2/ -> 0 }
-{ 4000 2/ -> 2000 }
-{ 1S 2/ -> 1S } \ MSB PROPOGATED
-{ 1S 1 XOR 2/ -> 1S }
-{ MSB 2/ MSB AND -> MSB }
-
-{ 1 0 LSHIFT -> 1 }
-{ 1 1 LSHIFT -> 2 }
-{ 1 2 LSHIFT -> 4 }
-{ 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT
-{ 1S 1 LSHIFT 1 XOR -> 1S }
-{ MSB 1 LSHIFT -> 0 }
-
-{ 1 0 RSHIFT -> 1 }
-{ 1 1 RSHIFT -> 0 }
-{ 2 1 RSHIFT -> 1 }
-{ 4 2 RSHIFT -> 1 }
-{ 8000 F RSHIFT -> 1 } \ BIGGEST
-{ MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS
-{ MSB 1 RSHIFT 2* -> MSB }
-
-\ ------------------------------------------------------------------------
-TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
-0 INVERT CONSTANT MAX-UINT
-0 INVERT 1 RSHIFT CONSTANT MAX-INT
-0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
-0 INVERT 1 RSHIFT CONSTANT MID-UINT
-0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
-
-0S CONSTANT <FALSE>
-1S CONSTANT <TRUE>
-
-{ 0 0= -> <TRUE> }
-{ 1 0= -> <FALSE> }
-{ 2 0= -> <FALSE> }
-{ -1 0= -> <FALSE> }
-{ MAX-UINT 0= -> <FALSE> }
-{ MIN-INT 0= -> <FALSE> }
-{ MAX-INT 0= -> <FALSE> }
-
-{ 0 0 = -> <TRUE> }
-{ 1 1 = -> <TRUE> }
-{ -1 -1 = -> <TRUE> }
-{ 1 0 = -> <FALSE> }
-{ -1 0 = -> <FALSE> }
-{ 0 1 = -> <FALSE> }
-{ 0 -1 = -> <FALSE> }
-
-{ 0 0< -> <FALSE> }
-{ -1 0< -> <TRUE> }
-{ MIN-INT 0< -> <TRUE> }
-{ 1 0< -> <FALSE> }
-{ MAX-INT 0< -> <FALSE> }
-
-{ 0 1 < -> <TRUE> }
-{ 1 2 < -> <TRUE> }
-{ -1 0 < -> <TRUE> }
-{ -1 1 < -> <TRUE> }
-{ MIN-INT 0 < -> <TRUE> }
-{ MIN-INT MAX-INT < -> <TRUE> }
-{ 0 MAX-INT < -> <TRUE> }
-{ 0 0 < -> <FALSE> }
-{ 1 1 < -> <FALSE> }
-{ 1 0 < -> <FALSE> }
-{ 2 1 < -> <FALSE> }
-{ 0 -1 < -> <FALSE> }
-{ 1 -1 < -> <FALSE> }
-{ 0 MIN-INT < -> <FALSE> }
-{ MAX-INT MIN-INT < -> <FALSE> }
-{ MAX-INT 0 < -> <FALSE> }
-
-{ 0 1 > -> <FALSE> }
-{ 1 2 > -> <FALSE> }
-{ -1 0 > -> <FALSE> }
-{ -1 1 > -> <FALSE> }
-{ MIN-INT 0 > -> <FALSE> }
-{ MIN-INT MAX-INT > -> <FALSE> }
-{ 0 MAX-INT > -> <FALSE> }
-{ 0 0 > -> <FALSE> }
-{ 1 1 > -> <FALSE> }
-{ 1 0 > -> <TRUE> }
-{ 2 1 > -> <TRUE> }
-{ 0 -1 > -> <TRUE> }
-{ 1 -1 > -> <TRUE> }
-{ 0 MIN-INT > -> <TRUE> }
-{ MAX-INT MIN-INT > -> <TRUE> }
-{ MAX-INT 0 > -> <TRUE> }
-
-{ 0 1 U< -> <TRUE> }
-{ 1 2 U< -> <TRUE> }
-{ 0 MID-UINT U< -> <TRUE> }
-{ 0 MAX-UINT U< -> <TRUE> }
-{ MID-UINT MAX-UINT U< -> <TRUE> }
-{ 0 0 U< -> <FALSE> }
-{ 1 1 U< -> <FALSE> }
-{ 1 0 U< -> <FALSE> }
-{ 2 1 U< -> <FALSE> }
-{ MID-UINT 0 U< -> <FALSE> }
-{ MAX-UINT 0 U< -> <FALSE> }
-{ MAX-UINT MID-UINT U< -> <FALSE> }
-
-{ 0 1 MIN -> 0 }
-{ 1 2 MIN -> 1 }
-{ -1 0 MIN -> -1 }
-{ -1 1 MIN -> -1 }
-{ MIN-INT 0 MIN -> MIN-INT }
-{ MIN-INT MAX-INT MIN -> MIN-INT }
-{ 0 MAX-INT MIN -> 0 }
-{ 0 0 MIN -> 0 }
-{ 1 1 MIN -> 1 }
-{ 1 0 MIN -> 0 }
-{ 2 1 MIN -> 1 }
-{ 0 -1 MIN -> -1 }
-{ 1 -1 MIN -> -1 }
-{ 0 MIN-INT MIN -> MIN-INT }
-{ MAX-INT MIN-INT MIN -> MIN-INT }
-{ MAX-INT 0 MIN -> 0 }
-
-{ 0 1 MAX -> 1 }
-{ 1 2 MAX -> 2 }
-{ -1 0 MAX -> 0 }
-{ -1 1 MAX -> 1 }
-{ MIN-INT 0 MAX -> 0 }
-{ MIN-INT MAX-INT MAX -> MAX-INT }
-{ 0 MAX-INT MAX -> MAX-INT }
-{ 0 0 MAX -> 0 }
-{ 1 1 MAX -> 1 }
-{ 1 0 MAX -> 1 }
-{ 2 1 MAX -> 2 }
-{ 0 -1 MAX -> 0 }
-{ 1 -1 MAX -> 1 }
-{ 0 MIN-INT MAX -> 0 }
-{ MAX-INT MIN-INT MAX -> MAX-INT }
-{ MAX-INT 0 MAX -> MAX-INT }
-
-\ ------------------------------------------------------------------------
-TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
-
-{ 1 2 2DROP -> }
-{ 1 2 2DUP -> 1 2 1 2 }
-{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
-{ 1 2 3 4 2SWAP -> 3 4 1 2 }
-{ 0 ?DUP -> 0 }
-{ 1 ?DUP -> 1 1 }
-{ -1 ?DUP -> -1 -1 }
-{ DEPTH -> 0 }
-{ 0 DEPTH -> 0 1 }
-{ 0 1 DEPTH -> 0 1 2 }
-{ 0 DROP -> }
-{ 1 2 DROP -> 1 }
-{ 1 DUP -> 1 1 }
-{ 1 2 OVER -> 1 2 1 }
-{ 1 2 3 ROT -> 2 3 1 }
-{ 1 2 SWAP -> 2 1 }
-
-\ ------------------------------------------------------------------------
-TESTING >R R> R@
-
-{ : GR1 >R R> ; -> }
-{ : GR2 >R R@ R> DROP ; -> }
-{ 123 GR1 -> 123 }
-{ 123 GR2 -> 123 }
-{ 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS )
-
-\ ------------------------------------------------------------------------
-TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
-
-{ 0 5 + -> 5 }
-{ 5 0 + -> 5 }
-{ 0 -5 + -> -5 }
-{ -5 0 + -> -5 }
-{ 1 2 + -> 3 }
-{ 1 -2 + -> -1 }
-{ -1 2 + -> 1 }
-{ -1 -2 + -> -3 }
-{ -1 1 + -> 0 }
-{ MID-UINT 1 + -> MID-UINT+1 }
-
-{ 0 5 - -> -5 }
-{ 5 0 - -> 5 }
-{ 0 -5 - -> 5 }
-{ -5 0 - -> -5 }
-{ 1 2 - -> -1 }
-{ 1 -2 - -> 3 }
-{ -1 2 - -> -3 }
-{ -1 -2 - -> 1 }
-{ 0 1 - -> -1 }
-{ MID-UINT+1 1 - -> MID-UINT }
-
-{ 0 1+ -> 1 }
-{ -1 1+ -> 0 }
-{ 1 1+ -> 2 }
-{ MID-UINT 1+ -> MID-UINT+1 }
-
-{ 2 1- -> 1 }
-{ 1 1- -> 0 }
-{ 0 1- -> -1 }
-{ MID-UINT+1 1- -> MID-UINT }
-
-{ 0 NEGATE -> 0 }
-{ 1 NEGATE -> -1 }
-{ -1 NEGATE -> 1 }
-{ 2 NEGATE -> -2 }
-{ -2 NEGATE -> 2 }
-
-{ 0 ABS -> 0 }
-{ 1 ABS -> 1 }
-{ -1 ABS -> 1 }
-{ MIN-INT ABS -> MID-UINT+1 }
-
-\ ------------------------------------------------------------------------
-TESTING MULTIPLY: S>D * M* UM*
-
-{ 0 S>D -> 0 0 }
-{ 1 S>D -> 1 0 }
-{ 2 S>D -> 2 0 }
-{ -1 S>D -> -1 -1 }
-{ -2 S>D -> -2 -1 }
-{ MIN-INT S>D -> MIN-INT -1 }
-{ MAX-INT S>D -> MAX-INT 0 }
-
-{ 0 0 M* -> 0 S>D }
-{ 0 1 M* -> 0 S>D }
-{ 1 0 M* -> 0 S>D }
-{ 1 2 M* -> 2 S>D }
-{ 2 1 M* -> 2 S>D }
-{ 3 3 M* -> 9 S>D }
-{ -3 3 M* -> -9 S>D }
-{ 3 -3 M* -> -9 S>D }
-{ -3 -3 M* -> 9 S>D }
-{ 0 MIN-INT M* -> 0 S>D }
-{ 1 MIN-INT M* -> MIN-INT S>D }
-{ 2 MIN-INT M* -> 0 1S }
-{ 0 MAX-INT M* -> 0 S>D }
-{ 1 MAX-INT M* -> MAX-INT S>D }
-{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
-{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
-{ MAX-INT MIN-INT M* -> MSB MSB 2/ }
-{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
-
-{ 0 0 * -> 0 } \ TEST IDENTITIES
-{ 0 1 * -> 0 }
-{ 1 0 * -> 0 }
-{ 1 2 * -> 2 }
-{ 2 1 * -> 2 }
-{ 3 3 * -> 9 }
-{ -3 3 * -> -9 }
-{ 3 -3 * -> -9 }
-{ -3 -3 * -> 9 }
-
-{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
-{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
-{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
-
-{ 0 0 UM* -> 0 0 }
-{ 0 1 UM* -> 0 0 }
-{ 1 0 UM* -> 0 0 }
-{ 1 2 UM* -> 2 0 }
-{ 2 1 UM* -> 2 0 }
-{ 3 3 UM* -> 9 0 }
-
-{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
-{ MID-UINT+1 2 UM* -> 0 1 }
-{ MID-UINT+1 4 UM* -> 0 2 }
-{ 1S 2 UM* -> 1S 1 LSHIFT 1 }
-{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
-
-\ ------------------------------------------------------------------------
-TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
-
-{ 0 S>D 1 FM/MOD -> 0 0 }
-{ 1 S>D 1 FM/MOD -> 0 1 }
-{ 2 S>D 1 FM/MOD -> 0 2 }
-{ -1 S>D 1 FM/MOD -> 0 -1 }
-{ -2 S>D 1 FM/MOD -> 0 -2 }
-{ 0 S>D -1 FM/MOD -> 0 0 }
-{ 1 S>D -1 FM/MOD -> 0 -1 }
-{ 2 S>D -1 FM/MOD -> 0 -2 }
-{ -1 S>D -1 FM/MOD -> 0 1 }
-{ -2 S>D -1 FM/MOD -> 0 2 }
-{ 2 S>D 2 FM/MOD -> 0 1 }
-{ -1 S>D -1 FM/MOD -> 0 1 }
-{ -2 S>D -2 FM/MOD -> 0 1 }
-{ 7 S>D 3 FM/MOD -> 1 2 }
-{ 7 S>D -3 FM/MOD -> -2 -3 }
-{ -7 S>D 3 FM/MOD -> 2 -3 }
-{ -7 S>D -3 FM/MOD -> -1 2 }
-{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
-{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
-{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
-{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
-{ 1S 1 4 FM/MOD -> 3 MAX-INT }
-{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
-{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
-{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
-{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
-{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
-{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
-{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
-{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
-{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
-{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
-{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
-{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
-
-{ 0 S>D 1 SM/REM -> 0 0 }
-{ 1 S>D 1 SM/REM -> 0 1 }
-{ 2 S>D 1 SM/REM -> 0 2 }
-{ -1 S>D 1 SM/REM -> 0 -1 }
-{ -2 S>D 1 SM/REM -> 0 -2 }
-{ 0 S>D -1 SM/REM -> 0 0 }
-{ 1 S>D -1 SM/REM -> 0 -1 }
-{ 2 S>D -1 SM/REM -> 0 -2 }
-{ -1 S>D -1 SM/REM -> 0 1 }
-{ -2 S>D -1 SM/REM -> 0 2 }
-{ 2 S>D 2 SM/REM -> 0 1 }
-{ -1 S>D -1 SM/REM -> 0 1 }
-{ -2 S>D -2 SM/REM -> 0 1 }
-{ 7 S>D 3 SM/REM -> 1 2 }
-{ 7 S>D -3 SM/REM -> 1 -2 }
-{ -7 S>D 3 SM/REM -> -1 -2 }
-{ -7 S>D -3 SM/REM -> -1 2 }
-{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
-{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
-{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }
-{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }
-{ 1S 1 4 SM/REM -> 3 MAX-INT }
-{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
-{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
-{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
-{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
-{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
-{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
-{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
-{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
-
-{ 0 0 1 UM/MOD -> 0 0 }
-{ 1 0 1 UM/MOD -> 0 1 }
-{ 1 0 2 UM/MOD -> 1 0 }
-{ 3 0 2 UM/MOD -> 1 1 }
-{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
-{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
-{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
-
-: IFFLOORED
- [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
-: IFSYM
- [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
-
-\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
-\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
-IFFLOORED : T/MOD >R S>D R> FM/MOD ;
-IFFLOORED : T/ T/MOD SWAP DROP ;
-IFFLOORED : TMOD T/MOD DROP ;
-IFFLOORED : T*/MOD >R M* R> FM/MOD ;
-IFFLOORED : T*/ T*/MOD SWAP DROP ;
-IFSYM : T/MOD >R S>D R> SM/REM ;
-IFSYM : T/ T/MOD SWAP DROP ;
-IFSYM : TMOD T/MOD DROP ;
-IFSYM : T*/MOD >R M* R> SM/REM ;
-IFSYM : T*/ T*/MOD SWAP DROP ;
-
-{ 0 1 /MOD -> 0 1 T/MOD }
-{ 1 1 /MOD -> 1 1 T/MOD }
-{ 2 1 /MOD -> 2 1 T/MOD }
-{ -1 1 /MOD -> -1 1 T/MOD }
-{ -2 1 /MOD -> -2 1 T/MOD }
-{ 0 -1 /MOD -> 0 -1 T/MOD }
-{ 1 -1 /MOD -> 1 -1 T/MOD }
-{ 2 -1 /MOD -> 2 -1 T/MOD }
-{ -1 -1 /MOD -> -1 -1 T/MOD }
-{ -2 -1 /MOD -> -2 -1 T/MOD }
-{ 2 2 /MOD -> 2 2 T/MOD }
-{ -1 -1 /MOD -> -1 -1 T/MOD }
-{ -2 -2 /MOD -> -2 -2 T/MOD }
-{ 7 3 /MOD -> 7 3 T/MOD }
-{ 7 -3 /MOD -> 7 -3 T/MOD }
-{ -7 3 /MOD -> -7 3 T/MOD }
-{ -7 -3 /MOD -> -7 -3 T/MOD }
-{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
-{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
-{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
-{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
-
-{ 0 1 / -> 0 1 T/ }
-{ 1 1 / -> 1 1 T/ }
-{ 2 1 / -> 2 1 T/ }
-{ -1 1 / -> -1 1 T/ }
-{ -2 1 / -> -2 1 T/ }
-{ 0 -1 / -> 0 -1 T/ }
-{ 1 -1 / -> 1 -1 T/ }
-{ 2 -1 / -> 2 -1 T/ }
-{ -1 -1 / -> -1 -1 T/ }
-{ -2 -1 / -> -2 -1 T/ }
-{ 2 2 / -> 2 2 T/ }
-{ -1 -1 / -> -1 -1 T/ }
-{ -2 -2 / -> -2 -2 T/ }
-{ 7 3 / -> 7 3 T/ }
-{ 7 -3 / -> 7 -3 T/ }
-{ -7 3 / -> -7 3 T/ }
-{ -7 -3 / -> -7 -3 T/ }
-{ MAX-INT 1 / -> MAX-INT 1 T/ }
-{ MIN-INT 1 / -> MIN-INT 1 T/ }
-{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
-{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
-
-{ 0 1 MOD -> 0 1 TMOD }
-{ 1 1 MOD -> 1 1 TMOD }
-{ 2 1 MOD -> 2 1 TMOD }
-{ -1 1 MOD -> -1 1 TMOD }
-{ -2 1 MOD -> -2 1 TMOD }
-{ 0 -1 MOD -> 0 -1 TMOD }
-{ 1 -1 MOD -> 1 -1 TMOD }
-{ 2 -1 MOD -> 2 -1 TMOD }
-{ -1 -1 MOD -> -1 -1 TMOD }
-{ -2 -1 MOD -> -2 -1 TMOD }
-{ 2 2 MOD -> 2 2 TMOD }
-{ -1 -1 MOD -> -1 -1 TMOD }
-{ -2 -2 MOD -> -2 -2 TMOD }
-{ 7 3 MOD -> 7 3 TMOD }
-{ 7 -3 MOD -> 7 -3 TMOD }
-{ -7 3 MOD -> -7 3 TMOD }
-{ -7 -3 MOD -> -7 -3 TMOD }
-{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }
-{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }
-{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
-{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
-
-{ 0 2 1 */ -> 0 2 1 T*/ }
-{ 1 2 1 */ -> 1 2 1 T*/ }
-{ 2 2 1 */ -> 2 2 1 T*/ }
-{ -1 2 1 */ -> -1 2 1 T*/ }
-{ -2 2 1 */ -> -2 2 1 T*/ }
-{ 0 2 -1 */ -> 0 2 -1 T*/ }
-{ 1 2 -1 */ -> 1 2 -1 T*/ }
-{ 2 2 -1 */ -> 2 2 -1 T*/ }
-{ -1 2 -1 */ -> -1 2 -1 T*/ }
-{ -2 2 -1 */ -> -2 2 -1 T*/ }
-{ 2 2 2 */ -> 2 2 2 T*/ }
-{ -1 2 -1 */ -> -1 2 -1 T*/ }
-{ -2 2 -2 */ -> -2 2 -2 T*/ }
-{ 7 2 3 */ -> 7 2 3 T*/ }
-{ 7 2 -3 */ -> 7 2 -3 T*/ }
-{ -7 2 3 */ -> -7 2 3 T*/ }
-{ -7 2 -3 */ -> -7 2 -3 T*/ }
-{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
-{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
-
-{ 0 2 1 */MOD -> 0 2 1 T*/MOD }
-{ 1 2 1 */MOD -> 1 2 1 T*/MOD }
-{ 2 2 1 */MOD -> 2 2 1 T*/MOD }
-{ -1 2 1 */MOD -> -1 2 1 T*/MOD }
-{ -2 2 1 */MOD -> -2 2 1 T*/MOD }
-{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
-{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
-{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
-{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
-{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
-{ 2 2 2 */MOD -> 2 2 2 T*/MOD }
-{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
-{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
-{ 7 2 3 */MOD -> 7 2 3 T*/MOD }
-{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
-{ -7 2 3 */MOD -> -7 2 3 T*/MOD }
-{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
-{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
-{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
-
-\ ------------------------------------------------------------------------
-TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
-
-HERE 1 ALLOT
-HERE
-CONSTANT 2NDA
-CONSTANT 1STA
-{ 1STA 2NDA U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
-{ 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT
-( MISSING TEST: NEGATIVE ALLOT )
-
-HERE 1 ,
-HERE 2 ,
-CONSTANT 2ND
-CONSTANT 1ST
-{ 1ST 2ND U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
-{ 1ST CELL+ -> 2ND } \ ... BY ONE CELL
-{ 1ST 1 CELLS + -> 2ND }
-{ 1ST @ 2ND @ -> 1 2 }
-{ 5 1ST ! -> }
-{ 1ST @ 2ND @ -> 5 2 }
-{ 6 2ND ! -> }
-{ 1ST @ 2ND @ -> 5 6 }
-{ 1ST 2@ -> 6 5 }
-{ 2 1 1ST 2! -> }
-{ 1ST 2@ -> 2 1 }
-{ 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE
-
-HERE 1 C,
-HERE 2 C,
-CONSTANT 2NDC
-CONSTANT 1STC
-{ 1STC 2NDC U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
-{ 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR
-{ 1STC 1 CHARS + -> 2NDC }
-{ 1STC C@ 2NDC C@ -> 1 2 }
-{ 3 1STC C! -> }
-{ 1STC C@ 2NDC C@ -> 3 2 }
-{ 4 2NDC C! -> }
-{ 1STC C@ 2NDC C@ -> 3 4 }
-
-ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
-CONSTANT A-ADDR CONSTANT UA-ADDR
-{ UA-ADDR ALIGNED -> A-ADDR }
-{ 1 A-ADDR C! A-ADDR C@ -> 1 }
-{ 1234 A-ADDR ! A-ADDR @ -> 1234 }
-{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }
-{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }
-{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }
-{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }
-{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }
-
-: BITS ( X -- U )
- 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
-( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
-{ 1 CHARS 1 < -> <FALSE> }
-{ 1 CHARS 1 CELLS > -> <FALSE> }
-( TBD: HOW TO FIND NUMBER OF BITS? )
-
-( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
-{ 1 CELLS 1 < -> <FALSE> }
-{ 1 CELLS 1 CHARS MOD -> 0 }
-{ 1S BITS 10 < -> <FALSE> }
-
-{ 0 1ST ! -> }
-{ 1 1ST +! -> }
-{ 1ST @ -> 1 }
-{ -1 1ST +! 1ST @ -> 0 }
-
-\ ------------------------------------------------------------------------
-TESTING CHAR [CHAR] [ ] BL S"
-
-{ BL -> 20 }
-{ CHAR X -> 58 }
-{ CHAR HELLO -> 48 }
-{ : GC1 [CHAR] X ; -> }
-{ : GC2 [CHAR] HELLO ; -> }
-{ GC1 -> 58 }
-{ GC2 -> 48 }
-{ : GC3 [ GC1 ] LITERAL ; -> }
-{ GC3 -> 58 }
-{ : GC4 S" XY" ; -> }
-{ GC4 SWAP DROP -> 2 }
-{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
-
-\ ------------------------------------------------------------------------
-TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
-
-{ : GT1 123 ; -> }
-{ ' GT1 EXECUTE -> 123 }
-{ : GT2 ['] GT1 ; IMMEDIATE -> }
-{ GT2 EXECUTE -> 123 }
-
-HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
-HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
-
-{ GT1STRING FIND -> ' GT1 -1 }
-{ GT2STRING FIND -> ' GT2 1 }
-( HOW TO SEARCH FOR NON-EXISTENT WORD? )
-{ : GT3 GT2 LITERAL ; -> }
-{ GT3 -> ' GT1 }
-{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }
-
-{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }
-{ : GT5 GT4 ; -> }
-{ GT5 -> 123 }
-{ : GT6 345 ; IMMEDIATE -> }
-{ : GT7 POSTPONE GT6 ; -> }
-{ GT7 -> 345 }
-
-{ : GT8 STATE @ ; IMMEDIATE -> }
-{ GT8 -> 0 }
-{ : GT9 GT8 LITERAL ; -> }
-{ GT9 0= -> <FALSE> }
-
-\ ------------------------------------------------------------------------
-TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
-
-{ : GI1 IF 123 THEN ; -> }
-{ : GI2 IF 123 ELSE 234 THEN ; -> }
-{ 0 GI1 -> }
-{ 1 GI1 -> 123 }
-{ -1 GI1 -> 123 }
-{ 0 GI2 -> 234 }
-{ 1 GI2 -> 123 }
-{ -1 GI1 -> 123 }
-
-{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
-{ 0 GI3 -> 0 1 2 3 4 5 }
-{ 4 GI3 -> 4 5 }
-{ 5 GI3 -> 5 }
-{ 6 GI3 -> 6 }
-
-{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
-{ 3 GI4 -> 3 4 5 6 }
-{ 5 GI4 -> 5 6 }
-{ 6 GI4 -> 6 7 }
-
-{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
-{ 1 GI5 -> 1 345 }
-{ 2 GI5 -> 2 345 }
-{ 3 GI5 -> 3 4 5 123 }
-{ 4 GI5 -> 4 5 123 }
-{ 5 GI5 -> 5 123 }
-
-{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
-{ 0 GI6 -> 0 }
-{ 1 GI6 -> 0 1 }
-{ 2 GI6 -> 0 1 2 }
-{ 3 GI6 -> 0 1 2 3 }
-{ 4 GI6 -> 0 1 2 3 4 }
-
-\ ------------------------------------------------------------------------
-TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
-
-{ : GD1 DO I LOOP ; -> }
-{ 4 1 GD1 -> 1 2 3 }
-{ 2 -1 GD1 -> -1 0 1 }
-{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }
-
-{ : GD2 DO I -1 +LOOP ; -> }
-{ 1 4 GD2 -> 4 3 2 1 }
-{ -1 2 GD2 -> 2 1 0 -1 }
-{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
-
-{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }
-{ 4 1 GD3 -> 1 2 3 }
-{ 2 -1 GD3 -> -1 0 1 }
-{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }
-
-{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
-{ 1 4 GD4 -> 4 3 2 1 }
-{ -1 2 GD4 -> 2 1 0 -1 }
-{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
-
-{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
-{ 1 GD5 -> 123 }
-{ 5 GD5 -> 123 }
-{ 6 GD5 -> 234 }
-
-{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
- 0 SWAP 0 DO
- I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
- LOOP ; -> }
-{ 1 GD6 -> 1 }
-{ 2 GD6 -> 3 }
-{ 3 GD6 -> 4 1 2 }
-
-\ ------------------------------------------------------------------------
-TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
-
-{ 123 CONSTANT X123 -> }
-{ X123 -> 123 }
-{ : EQU CONSTANT ; -> }
-{ X123 EQU Y123 -> }
-{ Y123 -> 123 }
-
-{ VARIABLE V1 -> }
-{ 123 V1 ! -> }
-{ V1 @ -> 123 }
-
-{ : NOP : POSTPONE ; ; -> }
-{ NOP NOP1 NOP NOP2 -> }
-{ NOP1 -> }
-{ NOP2 -> }
-
-{ : DOES1 DOES> @ 1 + ; -> }
-{ : DOES2 DOES> @ 2 + ; -> }
-{ CREATE CR1 -> }
-{ CR1 -> HERE }
-{ ' CR1 >BODY -> HERE }
-{ 1 , -> }
-{ CR1 @ -> 1 }
-{ DOES1 -> }
-{ CR1 -> 2 }
-{ DOES2 -> }
-{ CR1 -> 3 }
-
-{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
-{ WEIRD: W1 -> }
-{ ' W1 >BODY -> HERE }
-{ W1 -> HERE 1 + }
-{ W1 -> HERE 2 + }
-
-\ ------------------------------------------------------------------------
-TESTING EVALUATE
-
-: GE1 S" 123" ; IMMEDIATE
-: GE2 S" 123 1+" ; IMMEDIATE
-: GE3 S" : GE4 345 ;" ;
-: GE5 EVALUATE ; IMMEDIATE
-
-{ GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE )
-{ GE2 EVALUATE -> 124 }
-{ GE3 EVALUATE -> }
-{ GE4 -> 345 }
-
-{ : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE )
-{ GE6 -> 123 }
-{ : GE7 GE2 GE5 ; -> }
-{ GE7 -> 124 }
-
-\ ------------------------------------------------------------------------
-TESTING SOURCE >IN WORD
-
-: GS1 S" SOURCE" 2DUP EVALUATE
- >R SWAP >R = R> R> = ;
-{ GS1 -> <TRUE> <TRUE> }
-
-VARIABLE SCANS
-: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
-
-{ 2 SCANS !
-345 RESCAN?
--> 345 345 }
-: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ;
-{ GS2 -> 123 123 123 123 123 }
-
-: GS3 WORD COUNT SWAP C@ ;
-{ BL GS3 HELLO -> 5 CHAR H }
-{ CHAR " GS3 GOODBYE" -> 7 CHAR G }
-{ BL GS3
-DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING
-
-: GS4 SOURCE >IN ! DROP ;
-{ GS4 123 456
--> }
-
-\ ------------------------------------------------------------------------
-TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
-
-: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
- >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH
- R> ?DUP IF \ IF NON-EMPTY STRINGS
- 0 DO
- OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
- SWAP CHAR+ SWAP CHAR+
- LOOP
- THEN
- 2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH
- ELSE
- R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
- THEN ;
-
-: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
-{ GP1 -> <TRUE> }
-
-: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
-{ GP2 -> <TRUE> }
-
-: GP3 <# 1 0 # # #> S" 01" S= ;
-{ GP3 -> <TRUE> }
-
-: GP4 <# 1 0 #S #> S" 1" S= ;
-{ GP4 -> <TRUE> }
-
-24 CONSTANT MAX-BASE \ BASE 2 .. 36
-: COUNT-BITS
- 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
-COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD
-
-: GP5
- BASE @ <TRUE>
- MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
- I BASE ! \ TBD: ASSUMES BASE WORKS
- I 0 <# #S #> S" 10" S= AND
- LOOP
- SWAP BASE ! ;
-{ GP5 -> <TRUE> }
-
-: GP6
- BASE @ >R 2 BASE !
- MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
- R> BASE ! \ S: C-ADDR U
- DUP #BITS-UD = SWAP
- 0 DO \ S: C-ADDR FLAG
- OVER C@ [CHAR] 1 = AND \ ALL ONES
- >R CHAR+ R>
- LOOP SWAP DROP ;
-{ GP6 -> <TRUE> }
-
-: GP7
- BASE @ >R MAX-BASE BASE !
- <TRUE>
- A 0 DO
- I 0 <# #S #>
- 1 = SWAP C@ I 30 + = AND AND
- LOOP
- MAX-BASE A DO
- I 0 <# #S #>
- 1 = SWAP C@ 41 I A - + = AND AND
- LOOP
- R> BASE ! ;
-
-{ GP7 -> <TRUE> }
-
-\ >NUMBER TESTS
-CREATE GN-BUF 0 C,
-: GN-STRING GN-BUF 1 ;
-: GN-CONSUMED GN-BUF CHAR+ 0 ;
-: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ;
-
-{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
-{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
-{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
-{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE
-{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
-{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
-
-: >NUMBER-BASED
- BASE @ >R BASE ! >NUMBER R> BASE ! ;
-
-{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
-{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }
-{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
-{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
-{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
-{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
-
-: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
- BASE @ >R BASE !
- <# #S #>
- 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
- R> BASE ! ;
-{ 0 0 2 GN1 -> 0 0 0 }
-{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
-{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
-{ 0 0 MAX-BASE GN1 -> 0 0 0 }
-{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
-{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
-
-: GN2 \ ( -- 16 10 )
- BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
-{ GN2 -> 10 A }
-
-\ ------------------------------------------------------------------------
-TESTING FILL MOVE
-
-CREATE FBUF 00 C, 00 C, 00 C,
-CREATE SBUF 12 C, 34 C, 56 C,
-: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ;
-
-{ FBUF 0 20 FILL -> }
-{ SEEBUF -> 00 00 00 }
-
-{ FBUF 1 20 FILL -> }
-{ SEEBUF -> 20 00 00 }
-
-{ FBUF 3 20 FILL -> }
-{ SEEBUF -> 20 20 20 }
-
-{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE
-{ SEEBUF -> 20 20 20 }
-
-{ SBUF FBUF 0 CHARS MOVE -> }
-{ SEEBUF -> 20 20 20 }
-
-{ SBUF FBUF 1 CHARS MOVE -> }
-{ SEEBUF -> 12 20 20 }
-
-{ SBUF FBUF 3 CHARS MOVE -> }
-{ SEEBUF -> 12 34 56 }
-
-{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }
-{ SEEBUF -> 12 12 34 }
-
-{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }
-{ SEEBUF -> 12 34 34 }
-
-\ ------------------------------------------------------------------------
-TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
-
-: OUTPUT-TEST
- ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
- 41 BL DO I EMIT LOOP CR
- 61 41 DO I EMIT LOOP CR
- 7F 61 DO I EMIT LOOP CR
- ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
- 9 1+ 0 DO I . LOOP CR
- ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
- [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
- ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
- [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
- ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
- 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
- ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
- S" LINE 1" TYPE CR S" LINE 2" TYPE CR
- ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
- ." SIGNED: " MIN-INT . MAX-INT . CR
- ." UNSIGNED: " 0 U. MAX-UINT U. CR
-;
-
-{ OUTPUT-TEST -> }
-
-\ ------------------------------------------------------------------------
-TESTING INPUT: ACCEPT
-
-CREATE ABUF 80 CHARS ALLOT
-
-: ACCEPT-TEST
- CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
- ABUF 80 ACCEPT
- CR ." RECEIVED: " [CHAR] " EMIT
- ABUF SWAP TYPE [CHAR] " EMIT CR
-;
-
-{ ACCEPT-TEST -> }
-
-\ ------------------------------------------------------------------------
-TESTING DICTIONARY SEARCH RULES
-
-{ : GDX 123 ; : GDX GDX 234 ; -> }
-
-{ GDX -> 123 234 }
-
-
+\ From: John Hayes S1I
+\ Subject: core.fr
+\ Date: Mon, 27 Nov 95 13:10
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.2
+\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
+\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
+\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
+\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
+\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
+\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
+
+TESTING CORE WORDS
+HEX
+
+\ ------------------------------------------------------------------------
+TESTING BASIC ASSUMPTIONS
+
+{ -> } \ START WITH CLEAN SLATE
+( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
+{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
+{ 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR )
+{ 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT )
+{ -1 BITSSET? -> 0 0 }
+
+\ ------------------------------------------------------------------------
+TESTING BOOLEANS: INVERT AND OR XOR
+
+{ 0 0 AND -> 0 }
+{ 0 1 AND -> 0 }
+{ 1 0 AND -> 0 }
+{ 1 1 AND -> 1 }
+
+{ 0 INVERT 1 AND -> 1 }
+{ 1 INVERT 1 AND -> 0 }
+
+0 CONSTANT 0S
+0 INVERT CONSTANT 1S
+
+{ 0S INVERT -> 1S }
+{ 1S INVERT -> 0S }
+
+{ 0S 0S AND -> 0S }
+{ 0S 1S AND -> 0S }
+{ 1S 0S AND -> 0S }
+{ 1S 1S AND -> 1S }
+
+{ 0S 0S OR -> 0S }
+{ 0S 1S OR -> 1S }
+{ 1S 0S OR -> 1S }
+{ 1S 1S OR -> 1S }
+
+{ 0S 0S XOR -> 0S }
+{ 0S 1S XOR -> 1S }
+{ 1S 0S XOR -> 1S }
+{ 1S 1S XOR -> 0S }
+
+\ ------------------------------------------------------------------------
+TESTING 2* 2/ LSHIFT RSHIFT
+
+( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
+1S 1 RSHIFT INVERT CONSTANT MSB
+{ MSB BITSSET? -> 0 0 }
+
+{ 0S 2* -> 0S }
+{ 1 2* -> 2 }
+{ 4000 2* -> 8000 }
+{ 1S 2* 1 XOR -> 1S }
+{ MSB 2* -> 0S }
+
+{ 0S 2/ -> 0S }
+{ 1 2/ -> 0 }
+{ 4000 2/ -> 2000 }
+{ 1S 2/ -> 1S } \ MSB PROPOGATED
+{ 1S 1 XOR 2/ -> 1S }
+{ MSB 2/ MSB AND -> MSB }
+
+{ 1 0 LSHIFT -> 1 }
+{ 1 1 LSHIFT -> 2 }
+{ 1 2 LSHIFT -> 4 }
+{ 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT
+{ 1S 1 LSHIFT 1 XOR -> 1S }
+{ MSB 1 LSHIFT -> 0 }
+
+{ 1 0 RSHIFT -> 1 }
+{ 1 1 RSHIFT -> 0 }
+{ 2 1 RSHIFT -> 1 }
+{ 4 2 RSHIFT -> 1 }
+{ 8000 F RSHIFT -> 1 } \ BIGGEST
+{ MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS
+{ MSB 1 RSHIFT 2* -> MSB }
+
+\ ------------------------------------------------------------------------
+TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
+0 INVERT CONSTANT MAX-UINT
+0 INVERT 1 RSHIFT CONSTANT MAX-INT
+0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
+0 INVERT 1 RSHIFT CONSTANT MID-UINT
+0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
+
+0S CONSTANT <FALSE>
+1S CONSTANT <TRUE>
+
+{ 0 0= -> <TRUE> }
+{ 1 0= -> <FALSE> }
+{ 2 0= -> <FALSE> }
+{ -1 0= -> <FALSE> }
+{ MAX-UINT 0= -> <FALSE> }
+{ MIN-INT 0= -> <FALSE> }
+{ MAX-INT 0= -> <FALSE> }
+
+{ 0 0 = -> <TRUE> }
+{ 1 1 = -> <TRUE> }
+{ -1 -1 = -> <TRUE> }
+{ 1 0 = -> <FALSE> }
+{ -1 0 = -> <FALSE> }
+{ 0 1 = -> <FALSE> }
+{ 0 -1 = -> <FALSE> }
+
+{ 0 0< -> <FALSE> }
+{ -1 0< -> <TRUE> }
+{ MIN-INT 0< -> <TRUE> }
+{ 1 0< -> <FALSE> }
+{ MAX-INT 0< -> <FALSE> }
+
+{ 0 1 < -> <TRUE> }
+{ 1 2 < -> <TRUE> }
+{ -1 0 < -> <TRUE> }
+{ -1 1 < -> <TRUE> }
+{ MIN-INT 0 < -> <TRUE> }
+{ MIN-INT MAX-INT < -> <TRUE> }
+{ 0 MAX-INT < -> <TRUE> }
+{ 0 0 < -> <FALSE> }
+{ 1 1 < -> <FALSE> }
+{ 1 0 < -> <FALSE> }
+{ 2 1 < -> <FALSE> }
+{ 0 -1 < -> <FALSE> }
+{ 1 -1 < -> <FALSE> }
+{ 0 MIN-INT < -> <FALSE> }
+{ MAX-INT MIN-INT < -> <FALSE> }
+{ MAX-INT 0 < -> <FALSE> }
+
+{ 0 1 > -> <FALSE> }
+{ 1 2 > -> <FALSE> }
+{ -1 0 > -> <FALSE> }
+{ -1 1 > -> <FALSE> }
+{ MIN-INT 0 > -> <FALSE> }
+{ MIN-INT MAX-INT > -> <FALSE> }
+{ 0 MAX-INT > -> <FALSE> }
+{ 0 0 > -> <FALSE> }
+{ 1 1 > -> <FALSE> }
+{ 1 0 > -> <TRUE> }
+{ 2 1 > -> <TRUE> }
+{ 0 -1 > -> <TRUE> }
+{ 1 -1 > -> <TRUE> }
+{ 0 MIN-INT > -> <TRUE> }
+{ MAX-INT MIN-INT > -> <TRUE> }
+{ MAX-INT 0 > -> <TRUE> }
+
+{ 0 1 U< -> <TRUE> }
+{ 1 2 U< -> <TRUE> }
+{ 0 MID-UINT U< -> <TRUE> }
+{ 0 MAX-UINT U< -> <TRUE> }
+{ MID-UINT MAX-UINT U< -> <TRUE> }
+{ 0 0 U< -> <FALSE> }
+{ 1 1 U< -> <FALSE> }
+{ 1 0 U< -> <FALSE> }
+{ 2 1 U< -> <FALSE> }
+{ MID-UINT 0 U< -> <FALSE> }
+{ MAX-UINT 0 U< -> <FALSE> }
+{ MAX-UINT MID-UINT U< -> <FALSE> }
+
+{ 0 1 MIN -> 0 }
+{ 1 2 MIN -> 1 }
+{ -1 0 MIN -> -1 }
+{ -1 1 MIN -> -1 }
+{ MIN-INT 0 MIN -> MIN-INT }
+{ MIN-INT MAX-INT MIN -> MIN-INT }
+{ 0 MAX-INT MIN -> 0 }
+{ 0 0 MIN -> 0 }
+{ 1 1 MIN -> 1 }
+{ 1 0 MIN -> 0 }
+{ 2 1 MIN -> 1 }
+{ 0 -1 MIN -> -1 }
+{ 1 -1 MIN -> -1 }
+{ 0 MIN-INT MIN -> MIN-INT }
+{ MAX-INT MIN-INT MIN -> MIN-INT }
+{ MAX-INT 0 MIN -> 0 }
+
+{ 0 1 MAX -> 1 }
+{ 1 2 MAX -> 2 }
+{ -1 0 MAX -> 0 }
+{ -1 1 MAX -> 1 }
+{ MIN-INT 0 MAX -> 0 }
+{ MIN-INT MAX-INT MAX -> MAX-INT }
+{ 0 MAX-INT MAX -> MAX-INT }
+{ 0 0 MAX -> 0 }
+{ 1 1 MAX -> 1 }
+{ 1 0 MAX -> 1 }
+{ 2 1 MAX -> 2 }
+{ 0 -1 MAX -> 0 }
+{ 1 -1 MAX -> 1 }
+{ 0 MIN-INT MAX -> 0 }
+{ MAX-INT MIN-INT MAX -> MAX-INT }
+{ MAX-INT 0 MAX -> MAX-INT }
+
+\ ------------------------------------------------------------------------
+TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
+
+{ 1 2 2DROP -> }
+{ 1 2 2DUP -> 1 2 1 2 }
+{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
+{ 1 2 3 4 2SWAP -> 3 4 1 2 }
+{ 0 ?DUP -> 0 }
+{ 1 ?DUP -> 1 1 }
+{ -1 ?DUP -> -1 -1 }
+{ DEPTH -> 0 }
+{ 0 DEPTH -> 0 1 }
+{ 0 1 DEPTH -> 0 1 2 }
+{ 0 DROP -> }
+{ 1 2 DROP -> 1 }
+{ 1 DUP -> 1 1 }
+{ 1 2 OVER -> 1 2 1 }
+{ 1 2 3 ROT -> 2 3 1 }
+{ 1 2 SWAP -> 2 1 }
+
+\ ------------------------------------------------------------------------
+TESTING >R R> R@
+
+{ : GR1 >R R> ; -> }
+{ : GR2 >R R@ R> DROP ; -> }
+{ 123 GR1 -> 123 }
+{ 123 GR2 -> 123 }
+{ 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS )
+
+\ ------------------------------------------------------------------------
+TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
+
+{ 0 5 + -> 5 }
+{ 5 0 + -> 5 }
+{ 0 -5 + -> -5 }
+{ -5 0 + -> -5 }
+{ 1 2 + -> 3 }
+{ 1 -2 + -> -1 }
+{ -1 2 + -> 1 }
+{ -1 -2 + -> -3 }
+{ -1 1 + -> 0 }
+{ MID-UINT 1 + -> MID-UINT+1 }
+
+{ 0 5 - -> -5 }
+{ 5 0 - -> 5 }
+{ 0 -5 - -> 5 }
+{ -5 0 - -> -5 }
+{ 1 2 - -> -1 }
+{ 1 -2 - -> 3 }
+{ -1 2 - -> -3 }
+{ -1 -2 - -> 1 }
+{ 0 1 - -> -1 }
+{ MID-UINT+1 1 - -> MID-UINT }
+
+{ 0 1+ -> 1 }
+{ -1 1+ -> 0 }
+{ 1 1+ -> 2 }
+{ MID-UINT 1+ -> MID-UINT+1 }
+
+{ 2 1- -> 1 }
+{ 1 1- -> 0 }
+{ 0 1- -> -1 }
+{ MID-UINT+1 1- -> MID-UINT }
+
+{ 0 NEGATE -> 0 }
+{ 1 NEGATE -> -1 }
+{ -1 NEGATE -> 1 }
+{ 2 NEGATE -> -2 }
+{ -2 NEGATE -> 2 }
+
+{ 0 ABS -> 0 }
+{ 1 ABS -> 1 }
+{ -1 ABS -> 1 }
+{ MIN-INT ABS -> MID-UINT+1 }
+
+\ ------------------------------------------------------------------------
+TESTING MULTIPLY: S>D * M* UM*
+
+{ 0 S>D -> 0 0 }
+{ 1 S>D -> 1 0 }
+{ 2 S>D -> 2 0 }
+{ -1 S>D -> -1 -1 }
+{ -2 S>D -> -2 -1 }
+{ MIN-INT S>D -> MIN-INT -1 }
+{ MAX-INT S>D -> MAX-INT 0 }
+
+{ 0 0 M* -> 0 S>D }
+{ 0 1 M* -> 0 S>D }
+{ 1 0 M* -> 0 S>D }
+{ 1 2 M* -> 2 S>D }
+{ 2 1 M* -> 2 S>D }
+{ 3 3 M* -> 9 S>D }
+{ -3 3 M* -> -9 S>D }
+{ 3 -3 M* -> -9 S>D }
+{ -3 -3 M* -> 9 S>D }
+{ 0 MIN-INT M* -> 0 S>D }
+{ 1 MIN-INT M* -> MIN-INT S>D }
+{ 2 MIN-INT M* -> 0 1S }
+{ 0 MAX-INT M* -> 0 S>D }
+{ 1 MAX-INT M* -> MAX-INT S>D }
+{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
+{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
+{ MAX-INT MIN-INT M* -> MSB MSB 2/ }
+{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
+
+{ 0 0 * -> 0 } \ TEST IDENTITIES
+{ 0 1 * -> 0 }
+{ 1 0 * -> 0 }
+{ 1 2 * -> 2 }
+{ 2 1 * -> 2 }
+{ 3 3 * -> 9 }
+{ -3 3 * -> -9 }
+{ 3 -3 * -> -9 }
+{ -3 -3 * -> 9 }
+
+{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
+{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
+{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
+
+{ 0 0 UM* -> 0 0 }
+{ 0 1 UM* -> 0 0 }
+{ 1 0 UM* -> 0 0 }
+{ 1 2 UM* -> 2 0 }
+{ 2 1 UM* -> 2 0 }
+{ 3 3 UM* -> 9 0 }
+
+{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
+{ MID-UINT+1 2 UM* -> 0 1 }
+{ MID-UINT+1 4 UM* -> 0 2 }
+{ 1S 2 UM* -> 1S 1 LSHIFT 1 }
+{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
+
+\ ------------------------------------------------------------------------
+TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
+
+{ 0 S>D 1 FM/MOD -> 0 0 }
+{ 1 S>D 1 FM/MOD -> 0 1 }
+{ 2 S>D 1 FM/MOD -> 0 2 }
+{ -1 S>D 1 FM/MOD -> 0 -1 }
+{ -2 S>D 1 FM/MOD -> 0 -2 }
+{ 0 S>D -1 FM/MOD -> 0 0 }
+{ 1 S>D -1 FM/MOD -> 0 -1 }
+{ 2 S>D -1 FM/MOD -> 0 -2 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -1 FM/MOD -> 0 2 }
+{ 2 S>D 2 FM/MOD -> 0 1 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -2 FM/MOD -> 0 1 }
+{ 7 S>D 3 FM/MOD -> 1 2 }
+{ 7 S>D -3 FM/MOD -> -2 -3 }
+{ -7 S>D 3 FM/MOD -> 2 -3 }
+{ -7 S>D -3 FM/MOD -> -1 2 }
+{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
+{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
+{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
+{ 1S 1 4 FM/MOD -> 3 MAX-INT }
+{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
+{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
+{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
+{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
+{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
+{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
+
+{ 0 S>D 1 SM/REM -> 0 0 }
+{ 1 S>D 1 SM/REM -> 0 1 }
+{ 2 S>D 1 SM/REM -> 0 2 }
+{ -1 S>D 1 SM/REM -> 0 -1 }
+{ -2 S>D 1 SM/REM -> 0 -2 }
+{ 0 S>D -1 SM/REM -> 0 0 }
+{ 1 S>D -1 SM/REM -> 0 -1 }
+{ 2 S>D -1 SM/REM -> 0 -2 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -1 SM/REM -> 0 2 }
+{ 2 S>D 2 SM/REM -> 0 1 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -2 SM/REM -> 0 1 }
+{ 7 S>D 3 SM/REM -> 1 2 }
+{ 7 S>D -3 SM/REM -> 1 -2 }
+{ -7 S>D 3 SM/REM -> -1 -2 }
+{ -7 S>D -3 SM/REM -> -1 2 }
+{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
+{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }
+{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }
+{ 1S 1 4 SM/REM -> 3 MAX-INT }
+{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
+{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
+
+{ 0 0 1 UM/MOD -> 0 0 }
+{ 1 0 1 UM/MOD -> 0 1 }
+{ 1 0 2 UM/MOD -> 1 0 }
+{ 3 0 2 UM/MOD -> 1 1 }
+{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
+{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
+{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
+
+: IFFLOORED
+ [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+: IFSYM
+ [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+
+\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
+\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
+IFFLOORED : T/MOD >R S>D R> FM/MOD ;
+IFFLOORED : T/ T/MOD SWAP DROP ;
+IFFLOORED : TMOD T/MOD DROP ;
+IFFLOORED : T*/MOD >R M* R> FM/MOD ;
+IFFLOORED : T*/ T*/MOD SWAP DROP ;
+IFSYM : T/MOD >R S>D R> SM/REM ;
+IFSYM : T/ T/MOD SWAP DROP ;
+IFSYM : TMOD T/MOD DROP ;
+IFSYM : T*/MOD >R M* R> SM/REM ;
+IFSYM : T*/ T*/MOD SWAP DROP ;
+
+{ 0 1 /MOD -> 0 1 T/MOD }
+{ 1 1 /MOD -> 1 1 T/MOD }
+{ 2 1 /MOD -> 2 1 T/MOD }
+{ -1 1 /MOD -> -1 1 T/MOD }
+{ -2 1 /MOD -> -2 1 T/MOD }
+{ 0 -1 /MOD -> 0 -1 T/MOD }
+{ 1 -1 /MOD -> 1 -1 T/MOD }
+{ 2 -1 /MOD -> 2 -1 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -1 /MOD -> -2 -1 T/MOD }
+{ 2 2 /MOD -> 2 2 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -2 /MOD -> -2 -2 T/MOD }
+{ 7 3 /MOD -> 7 3 T/MOD }
+{ 7 -3 /MOD -> 7 -3 T/MOD }
+{ -7 3 /MOD -> -7 3 T/MOD }
+{ -7 -3 /MOD -> -7 -3 T/MOD }
+{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
+{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
+{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
+{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
+
+{ 0 1 / -> 0 1 T/ }
+{ 1 1 / -> 1 1 T/ }
+{ 2 1 / -> 2 1 T/ }
+{ -1 1 / -> -1 1 T/ }
+{ -2 1 / -> -2 1 T/ }
+{ 0 -1 / -> 0 -1 T/ }
+{ 1 -1 / -> 1 -1 T/ }
+{ 2 -1 / -> 2 -1 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -1 / -> -2 -1 T/ }
+{ 2 2 / -> 2 2 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -2 / -> -2 -2 T/ }
+{ 7 3 / -> 7 3 T/ }
+{ 7 -3 / -> 7 -3 T/ }
+{ -7 3 / -> -7 3 T/ }
+{ -7 -3 / -> -7 -3 T/ }
+{ MAX-INT 1 / -> MAX-INT 1 T/ }
+{ MIN-INT 1 / -> MIN-INT 1 T/ }
+{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
+{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
+
+{ 0 1 MOD -> 0 1 TMOD }
+{ 1 1 MOD -> 1 1 TMOD }
+{ 2 1 MOD -> 2 1 TMOD }
+{ -1 1 MOD -> -1 1 TMOD }
+{ -2 1 MOD -> -2 1 TMOD }
+{ 0 -1 MOD -> 0 -1 TMOD }
+{ 1 -1 MOD -> 1 -1 TMOD }
+{ 2 -1 MOD -> 2 -1 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -1 MOD -> -2 -1 TMOD }
+{ 2 2 MOD -> 2 2 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -2 MOD -> -2 -2 TMOD }
+{ 7 3 MOD -> 7 3 TMOD }
+{ 7 -3 MOD -> 7 -3 TMOD }
+{ -7 3 MOD -> -7 3 TMOD }
+{ -7 -3 MOD -> -7 -3 TMOD }
+{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }
+{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }
+{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
+{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
+
+{ 0 2 1 */ -> 0 2 1 T*/ }
+{ 1 2 1 */ -> 1 2 1 T*/ }
+{ 2 2 1 */ -> 2 2 1 T*/ }
+{ -1 2 1 */ -> -1 2 1 T*/ }
+{ -2 2 1 */ -> -2 2 1 T*/ }
+{ 0 2 -1 */ -> 0 2 -1 T*/ }
+{ 1 2 -1 */ -> 1 2 -1 T*/ }
+{ 2 2 -1 */ -> 2 2 -1 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -1 */ -> -2 2 -1 T*/ }
+{ 2 2 2 */ -> 2 2 2 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -2 */ -> -2 2 -2 T*/ }
+{ 7 2 3 */ -> 7 2 3 T*/ }
+{ 7 2 -3 */ -> 7 2 -3 T*/ }
+{ -7 2 3 */ -> -7 2 3 T*/ }
+{ -7 2 -3 */ -> -7 2 -3 T*/ }
+{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
+{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
+
+{ 0 2 1 */MOD -> 0 2 1 T*/MOD }
+{ 1 2 1 */MOD -> 1 2 1 T*/MOD }
+{ 2 2 1 */MOD -> 2 2 1 T*/MOD }
+{ -1 2 1 */MOD -> -1 2 1 T*/MOD }
+{ -2 2 1 */MOD -> -2 2 1 T*/MOD }
+{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
+{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
+{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
+{ 2 2 2 */MOD -> 2 2 2 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
+{ 7 2 3 */MOD -> 7 2 3 T*/MOD }
+{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
+{ -7 2 3 */MOD -> -7 2 3 T*/MOD }
+{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
+{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
+{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
+
+\ ------------------------------------------------------------------------
+TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
+
+HERE 1 ALLOT
+HERE
+CONSTANT 2NDA
+CONSTANT 1STA
+{ 1STA 2NDA U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
+{ 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT
+( MISSING TEST: NEGATIVE ALLOT )
+
+HERE 1 ,
+HERE 2 ,
+CONSTANT 2ND
+CONSTANT 1ST
+{ 1ST 2ND U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
+{ 1ST CELL+ -> 2ND } \ ... BY ONE CELL
+{ 1ST 1 CELLS + -> 2ND }
+{ 1ST @ 2ND @ -> 1 2 }
+{ 5 1ST ! -> }
+{ 1ST @ 2ND @ -> 5 2 }
+{ 6 2ND ! -> }
+{ 1ST @ 2ND @ -> 5 6 }
+{ 1ST 2@ -> 6 5 }
+{ 2 1 1ST 2! -> }
+{ 1ST 2@ -> 2 1 }
+{ 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE
+
+HERE 1 C,
+HERE 2 C,
+CONSTANT 2NDC
+CONSTANT 1STC
+{ 1STC 2NDC U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
+{ 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR
+{ 1STC 1 CHARS + -> 2NDC }
+{ 1STC C@ 2NDC C@ -> 1 2 }
+{ 3 1STC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 2 }
+{ 4 2NDC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 4 }
+
+ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
+CONSTANT A-ADDR CONSTANT UA-ADDR
+{ UA-ADDR ALIGNED -> A-ADDR }
+{ 1 A-ADDR C! A-ADDR C@ -> 1 }
+{ 1234 A-ADDR ! A-ADDR @ -> 1234 }
+{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }
+{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }
+{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }
+{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }
+{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }
+
+: BITS ( X -- U )
+ 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
+( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
+{ 1 CHARS 1 < -> <FALSE> }
+{ 1 CHARS 1 CELLS > -> <FALSE> }
+( TBD: HOW TO FIND NUMBER OF BITS? )
+
+( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
+{ 1 CELLS 1 < -> <FALSE> }
+{ 1 CELLS 1 CHARS MOD -> 0 }
+{ 1S BITS 10 < -> <FALSE> }
+
+{ 0 1ST ! -> }
+{ 1 1ST +! -> }
+{ 1ST @ -> 1 }
+{ -1 1ST +! 1ST @ -> 0 }
+
+\ ------------------------------------------------------------------------
+TESTING CHAR [CHAR] [ ] BL S"
+
+{ BL -> 20 }
+{ CHAR X -> 58 }
+{ CHAR HELLO -> 48 }
+{ : GC1 [CHAR] X ; -> }
+{ : GC2 [CHAR] HELLO ; -> }
+{ GC1 -> 58 }
+{ GC2 -> 48 }
+{ : GC3 [ GC1 ] LITERAL ; -> }
+{ GC3 -> 58 }
+{ : GC4 S" XY" ; -> }
+{ GC4 SWAP DROP -> 2 }
+{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
+
+\ ------------------------------------------------------------------------
+TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
+
+{ : GT1 123 ; -> }
+{ ' GT1 EXECUTE -> 123 }
+{ : GT2 ['] GT1 ; IMMEDIATE -> }
+{ GT2 EXECUTE -> 123 }
+
+HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
+HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
+
+{ GT1STRING FIND -> ' GT1 -1 }
+{ GT2STRING FIND -> ' GT2 1 }
+( HOW TO SEARCH FOR NON-EXISTENT WORD? )
+{ : GT3 GT2 LITERAL ; -> }
+{ GT3 -> ' GT1 }
+{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }
+
+{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }
+{ : GT5 GT4 ; -> }
+{ GT5 -> 123 }
+{ : GT6 345 ; IMMEDIATE -> }
+{ : GT7 POSTPONE GT6 ; -> }
+{ GT7 -> 345 }
+
+{ : GT8 STATE @ ; IMMEDIATE -> }
+{ GT8 -> 0 }
+{ : GT9 GT8 LITERAL ; -> }
+{ GT9 0= -> <FALSE> }
+
+\ ------------------------------------------------------------------------
+TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
+
+{ : GI1 IF 123 THEN ; -> }
+{ : GI2 IF 123 ELSE 234 THEN ; -> }
+{ 0 GI1 -> }
+{ 1 GI1 -> 123 }
+{ -1 GI1 -> 123 }
+{ 0 GI2 -> 234 }
+{ 1 GI2 -> 123 }
+{ -1 GI1 -> 123 }
+
+{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
+{ 0 GI3 -> 0 1 2 3 4 5 }
+{ 4 GI3 -> 4 5 }
+{ 5 GI3 -> 5 }
+{ 6 GI3 -> 6 }
+
+{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
+{ 3 GI4 -> 3 4 5 6 }
+{ 5 GI4 -> 5 6 }
+{ 6 GI4 -> 6 7 }
+
+{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
+{ 1 GI5 -> 1 345 }
+{ 2 GI5 -> 2 345 }
+{ 3 GI5 -> 3 4 5 123 }
+{ 4 GI5 -> 4 5 123 }
+{ 5 GI5 -> 5 123 }
+
+{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
+{ 0 GI6 -> 0 }
+{ 1 GI6 -> 0 1 }
+{ 2 GI6 -> 0 1 2 }
+{ 3 GI6 -> 0 1 2 3 }
+{ 4 GI6 -> 0 1 2 3 4 }
+
+\ ------------------------------------------------------------------------
+TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
+
+{ : GD1 DO I LOOP ; -> }
+{ 4 1 GD1 -> 1 2 3 }
+{ 2 -1 GD1 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }
+
+{ : GD2 DO I -1 +LOOP ; -> }
+{ 1 4 GD2 -> 4 3 2 1 }
+{ -1 2 GD2 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
+
+{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }
+{ 4 1 GD3 -> 1 2 3 }
+{ 2 -1 GD3 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }
+
+{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
+{ 1 4 GD4 -> 4 3 2 1 }
+{ -1 2 GD4 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
+
+{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
+{ 1 GD5 -> 123 }
+{ 5 GD5 -> 123 }
+{ 6 GD5 -> 234 }
+
+{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
+ 0 SWAP 0 DO
+ I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
+ LOOP ; -> }
+{ 1 GD6 -> 1 }
+{ 2 GD6 -> 3 }
+{ 3 GD6 -> 4 1 2 }
+
+\ ------------------------------------------------------------------------
+TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
+
+{ 123 CONSTANT X123 -> }
+{ X123 -> 123 }
+{ : EQU CONSTANT ; -> }
+{ X123 EQU Y123 -> }
+{ Y123 -> 123 }
+
+{ VARIABLE V1 -> }
+{ 123 V1 ! -> }
+{ V1 @ -> 123 }
+
+{ : NOP : POSTPONE ; ; -> }
+{ NOP NOP1 NOP NOP2 -> }
+{ NOP1 -> }
+{ NOP2 -> }
+
+{ : DOES1 DOES> @ 1 + ; -> }
+{ : DOES2 DOES> @ 2 + ; -> }
+{ CREATE CR1 -> }
+{ CR1 -> HERE }
+{ ' CR1 >BODY -> HERE }
+{ 1 , -> }
+{ CR1 @ -> 1 }
+{ DOES1 -> }
+{ CR1 -> 2 }
+{ DOES2 -> }
+{ CR1 -> 3 }
+
+{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
+{ WEIRD: W1 -> }
+{ ' W1 >BODY -> HERE }
+{ W1 -> HERE 1 + }
+{ W1 -> HERE 2 + }
+
+\ ------------------------------------------------------------------------
+TESTING EVALUATE
+
+: GE1 S" 123" ; IMMEDIATE
+: GE2 S" 123 1+" ; IMMEDIATE
+: GE3 S" : GE4 345 ;" ;
+: GE5 EVALUATE ; IMMEDIATE
+
+{ GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE )
+{ GE2 EVALUATE -> 124 }
+{ GE3 EVALUATE -> }
+{ GE4 -> 345 }
+
+{ : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE )
+{ GE6 -> 123 }
+{ : GE7 GE2 GE5 ; -> }
+{ GE7 -> 124 }
+
+\ ------------------------------------------------------------------------
+TESTING SOURCE >IN WORD
+
+: GS1 S" SOURCE" 2DUP EVALUATE
+ >R SWAP >R = R> R> = ;
+{ GS1 -> <TRUE> <TRUE> }
+
+VARIABLE SCANS
+: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
+
+{ 2 SCANS !
+345 RESCAN?
+-> 345 345 }
+: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ;
+{ GS2 -> 123 123 123 123 123 }
+
+: GS3 WORD COUNT SWAP C@ ;
+{ BL GS3 HELLO -> 5 CHAR H }
+{ CHAR " GS3 GOODBYE" -> 7 CHAR G }
+{ BL GS3
+DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING
+
+: GS4 SOURCE >IN ! DROP ;
+{ GS4 123 456
+-> }
+
+\ ------------------------------------------------------------------------
+TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
+
+: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
+ >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH
+ R> ?DUP IF \ IF NON-EMPTY STRINGS
+ 0 DO
+ OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
+ SWAP CHAR+ SWAP CHAR+
+ LOOP
+ THEN
+ 2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH
+ ELSE
+ R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
+ THEN ;
+
+: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+{ GP1 -> <TRUE> }
+
+: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+{ GP2 -> <TRUE> }
+
+: GP3 <# 1 0 # # #> S" 01" S= ;
+{ GP3 -> <TRUE> }
+
+: GP4 <# 1 0 #S #> S" 1" S= ;
+{ GP4 -> <TRUE> }
+
+24 CONSTANT MAX-BASE \ BASE 2 .. 36
+: COUNT-BITS
+ 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
+COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD
+
+: GP5
+ BASE @ <TRUE>
+ MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
+ I BASE ! \ TBD: ASSUMES BASE WORKS
+ I 0 <# #S #> S" 10" S= AND
+ LOOP
+ SWAP BASE ! ;
+{ GP5 -> <TRUE> }
+
+: GP6
+ BASE @ >R 2 BASE !
+ MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
+ R> BASE ! \ S: C-ADDR U
+ DUP #BITS-UD = SWAP
+ 0 DO \ S: C-ADDR FLAG
+ OVER C@ [CHAR] 1 = AND \ ALL ONES
+ >R CHAR+ R>
+ LOOP SWAP DROP ;
+{ GP6 -> <TRUE> }
+
+: GP7
+ BASE @ >R MAX-BASE BASE !
+ <TRUE>
+ A 0 DO
+ I 0 <# #S #>
+ 1 = SWAP C@ I 30 + = AND AND
+ LOOP
+ MAX-BASE A DO
+ I 0 <# #S #>
+ 1 = SWAP C@ 41 I A - + = AND AND
+ LOOP
+ R> BASE ! ;
+
+{ GP7 -> <TRUE> }
+
+\ >NUMBER TESTS
+CREATE GN-BUF 0 C,
+: GN-STRING GN-BUF 1 ;
+: GN-CONSUMED GN-BUF CHAR+ 0 ;
+: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ;
+
+{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
+{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
+{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
+{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE
+{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
+{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
+
+: >NUMBER-BASED
+ BASE @ >R BASE ! >NUMBER R> BASE ! ;
+
+{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
+{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
+{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
+{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
+
+: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+ BASE @ >R BASE !
+ <# #S #>
+ 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
+ R> BASE ! ;
+{ 0 0 2 GN1 -> 0 0 0 }
+{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
+{ 0 0 MAX-BASE GN1 -> 0 0 0 }
+{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
+
+: GN2 \ ( -- 16 10 )
+ BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
+{ GN2 -> 10 A }
+
+\ ------------------------------------------------------------------------
+TESTING FILL MOVE
+
+CREATE FBUF 00 C, 00 C, 00 C,
+CREATE SBUF 12 C, 34 C, 56 C,
+: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ;
+
+{ FBUF 0 20 FILL -> }
+{ SEEBUF -> 00 00 00 }
+
+{ FBUF 1 20 FILL -> }
+{ SEEBUF -> 20 00 00 }
+
+{ FBUF 3 20 FILL -> }
+{ SEEBUF -> 20 20 20 }
+
+{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 0 CHARS MOVE -> }
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 1 CHARS MOVE -> }
+{ SEEBUF -> 12 20 20 }
+
+{ SBUF FBUF 3 CHARS MOVE -> }
+{ SEEBUF -> 12 34 56 }
+
+{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }
+{ SEEBUF -> 12 12 34 }
+
+{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }
+{ SEEBUF -> 12 34 34 }
+
+\ ------------------------------------------------------------------------
+TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
+
+: OUTPUT-TEST
+ ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
+ 41 BL DO I EMIT LOOP CR
+ 61 41 DO I EMIT LOOP CR
+ 7F 61 DO I EMIT LOOP CR
+ ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
+ 9 1+ 0 DO I . LOOP CR
+ ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
+ [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
+ ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
+ [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
+ ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
+ 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
+ ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
+ S" LINE 1" TYPE CR S" LINE 2" TYPE CR
+ ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
+ ." SIGNED: " MIN-INT . MAX-INT . CR
+ ." UNSIGNED: " 0 U. MAX-UINT U. CR
+;
+
+{ OUTPUT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING INPUT: ACCEPT
+
+CREATE ABUF 80 CHARS ALLOT
+
+: ACCEPT-TEST
+ CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
+ ABUF 80 ACCEPT
+ CR ." RECEIVED: " [CHAR] " EMIT
+ ABUF SWAP TYPE [CHAR] " EMIT CR
+;
+
+{ ACCEPT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING DICTIONARY SEARCH RULES
+
+{ : GDX 123 ; : GDX GDX 234 ; -> }
+
+{ GDX -> 123 234 }
+
+
diff --git a/test/fib.fr b/test/fib.fr
index 24780a73b264..4dee9856fbed 100644
--- a/test/fib.fr
+++ b/test/fib.fr
@@ -1,12 +1,12 @@
-: fib ( n1 -- n2 )
- dup 1 > if
- dup
- 1- recurse
- swap 2 - recurse
- +
- then ;
-
-
-35 value nfibs
-: fibtest nfibs fib . cr ;
-
+: fib ( n1 -- n2 )
+ dup 1 > if
+ dup
+ 1- recurse
+ swap 2 - recurse
+ +
+ then ;
+
+
+35 value nfibs
+: fibtest nfibs fib . cr ;
+
diff --git a/test/ficltest.fr b/test/ficltest.fr
index c67a0f753f5c..3bed5b7f9b23 100644
--- a/test/ficltest.fr
+++ b/test/ficltest.fr
@@ -1,106 +1,106 @@
-\ test file for ficl
-\ test ANSI CORE stuff first...
--1 set-order
-
-\ set up local variable regressions before { gets redefined!
-: local1 { a b c | clr -- c b a 0 }
- c b a clr
-;
-
-: local2 { | clr -- 0 } clr ;
-: local3 { a b | c }
- a to c
- b to a
- c to b
- a b
-;
-
-load tester.fr
-load core.fr
-
-{ -> }
-\ test double stuff
-testing 2>r 2r> 2r@
-: 2r1 2>r r> r> swap ;
-: 2r2 swap >r >r 2r> ;
-: 2r3 2>r 2r@ R> R> 2DUP >R >R SWAP 2r> ;
-
-{ 1 2 2r1 -> 1 2 }
-{ 1 2 2r2 -> 1 2 }
-{ 1 2 2r3 -> 1 2 1 2 1 2 }
-{ -> }
-
-\ Now test ficl extras and optional word-sets
-testing locals
-{ 1 2 3 local1 -> 3 2 1 0 }
-{ local2 -> 0 }
-{ 1 local2 -> 1 0 }
-{ 1 2 local3 -> 2 1 }
-
-testing :noname
-{ :noname 1 ; execute -> 1 }
-{ 1 2 3 -rot -> 3 1 2 }
-
-testing default search order
-{ get-order -> forth-wordlist 1 }
-{ only definitions get-order -> forth-wordlist 1 }
-
-testing forget
-here constant fence
-{ fence forget fence -> here }
-
-testing within
-{ -1 1 0 within -> true }
-{ 0 1s 2 within -> true }
-{ -100 0 -1 within -> true }
-{ -1 1 2 within -> false }
-{ -1 1 -2 within -> false }
-{ 1 -5 5 within -> true }
-{ 33000 32000 34000 within -> true }
-{ 0x80000000 0x7f000000 0x81000000 within -> true }
-
-testing exception words
-: exc1 1 throw ;
-: exctest1 [ ' exc1 ] literal catch ;
-: exc2 exctest1 1 = if 2 throw endif ;
-: exctest2 [ ' exc2 ] literal catch ;
-: exctest? ' catch ;
-
-{ exctest1 -> 1 }
-{ exctest2 -> 2 }
-{ exctest? abort -> -1 }
-
-testing refill
-\ from file loading
-0 [if]
-.( Error )
-[else]
-1 [if]
-[else]
-.( Error )
-[then]
-[then]
-
-\ refill from evaluate string
-{ -> }
-{ s" 1 refill 2 " evaluate -> 1 0 2 }
-
-
-testing prefixes
-{ 0x10 -> decimal 16 }
-{ hex 0d10 -> decimal 10 }
-{ hex 100
--> decimal 256 }
-
-testing number builder
-{ 1 -> 1 }
-{ 3. -> 0 3 }
-
-
-s" ficlwin" environment?
-[if]
-drop
-testing OOP support
-load ooptest.fr
-[endif]
-
+\ test file for ficl
+\ test ANSI CORE stuff first...
+-1 set-order
+
+\ set up local variable regressions before { gets redefined!
+: local1 { a b c | clr -- c b a 0 }
+ c b a clr
+;
+
+: local2 { | clr -- 0 } clr ;
+: local3 { a b | c }
+ a to c
+ b to a
+ c to b
+ a b
+;
+
+load tester.fr
+load core.fr
+
+{ -> }
+\ test double stuff
+testing 2>r 2r> 2r@
+: 2r1 2>r r> r> swap ;
+: 2r2 swap >r >r 2r> ;
+: 2r3 2>r 2r@ R> R> 2DUP >R >R SWAP 2r> ;
+
+{ 1 2 2r1 -> 1 2 }
+{ 1 2 2r2 -> 1 2 }
+{ 1 2 2r3 -> 1 2 1 2 1 2 }
+{ -> }
+
+\ Now test ficl extras and optional word-sets
+testing locals
+{ 1 2 3 local1 -> 3 2 1 0 }
+{ local2 -> 0 }
+{ 1 local2 -> 1 0 }
+{ 1 2 local3 -> 2 1 }
+
+testing :noname
+{ :noname 1 ; execute -> 1 }
+{ 1 2 3 -rot -> 3 1 2 }
+
+testing default search order
+{ get-order -> forth-wordlist 1 }
+{ only definitions get-order -> forth-wordlist 1 }
+
+testing forget
+here constant fence
+{ fence forget fence -> here }
+
+testing within
+{ -1 1 0 within -> true }
+{ 0 1s 2 within -> true }
+{ -100 0 -1 within -> true }
+{ -1 1 2 within -> false }
+{ -1 1 -2 within -> false }
+{ 1 -5 5 within -> true }
+{ 33000 32000 34000 within -> true }
+{ 0x80000000 0x7f000000 0x81000000 within -> true }
+
+testing exception words
+: exc1 1 throw ;
+: exctest1 [ ' exc1 ] literal catch ;
+: exc2 exctest1 1 = if 2 throw endif ;
+: exctest2 [ ' exc2 ] literal catch ;
+: exctest? ' catch ;
+
+{ exctest1 -> 1 }
+{ exctest2 -> 2 }
+{ exctest? abort -> -1 }
+
+testing refill
+\ from file loading
+0 [if]
+.( Error )
+[else]
+1 [if]
+[else]
+.( Error )
+[then]
+[then]
+
+\ refill from evaluate string
+{ -> }
+{ s" 1 refill 2 " evaluate -> 1 0 2 }
+
+
+testing prefixes
+{ 0x10 -> decimal 16 }
+{ hex 0d10 -> decimal 10 }
+{ hex 100
+-> decimal 256 }
+
+testing number builder
+{ 1 -> 1 }
+{ 3. -> 0 3 }
+
+
+s" ficlwin" environment?
+[if]
+drop
+testing OOP support
+load ooptest.fr
+[endif]
+
diff --git a/test/ooptest.fr b/test/ooptest.fr
index 54abb8a22ce2..bfda3fc257d3 100644
--- a/test/ooptest.fr
+++ b/test/ooptest.fr
@@ -1,73 +1,73 @@
-\ OOP test stuff
-
-only
-also oop definitions
-
-object subclass c-aggregate
-c-byte obj: m0
-c-byte obj: m1
-c-4byte obj: m2
-c-2byte obj: m3
-end-class
-
-object --> sub class1
-
-cell: .a
-cell: .b
-: init
- locals| class inst |
- 0 inst class --> .a !
- 1 inst class --> .b !
-;
-end-class
-
-class1 --> new c1inst
-
-class1 --> sub class2
-cell: .c
-cell: .d
-
-: init
- locals| class inst |
- inst class --> super --> init
- 2 inst class --> .c !
- 3 inst class --> .d !
-;
-end-class
-
-class2 --> new c2inst
-
-object subclass c-list
-c-list ref: link
-c-ref obj: payload
-end-class
-
-\ test stuff from ficl.html
-.( metaclass methods ) cr
-metaclass --> methods
-
-cr .( c-foo class ) cr
-object --> sub c-foo
-cell: m_cell1
- 4 chars: m_chars
- : init ( inst class -- )
- locals| class inst |
- 0 inst class --> m_cell1 !
- inst class --> m_chars 4 0 fill
- ." initializing an instance of c_foo at " inst x. cr
- ;
-end-class
-
-.( c-foo instance methods... ) cr
-c-foo --> new foo-instance
-cr
-foo-instance --> methods
-foo-instance --> pedigree
-cr
-foo-instance 2dup
- --> methods
- --> pedigree
-cr
-c-foo --> see init
-cr
-foo-instance --> class --> see init
+\ OOP test stuff
+
+only
+also oop definitions
+
+object subclass c-aggregate
+c-byte obj: m0
+c-byte obj: m1
+c-4byte obj: m2
+c-2byte obj: m3
+end-class
+
+object --> sub class1
+
+cell: .a
+cell: .b
+: init
+ locals| class inst |
+ 0 inst class --> .a !
+ 1 inst class --> .b !
+;
+end-class
+
+class1 --> new c1inst
+
+class1 --> sub class2
+cell: .c
+cell: .d
+
+: init
+ locals| class inst |
+ inst class --> super --> init
+ 2 inst class --> .c !
+ 3 inst class --> .d !
+;
+end-class
+
+class2 --> new c2inst
+
+object subclass c-list
+c-list ref: link
+c-ref obj: payload
+end-class
+
+\ test stuff from ficl.html
+.( metaclass methods ) cr
+metaclass --> methods
+
+cr .( c-foo class ) cr
+object --> sub c-foo
+cell: m_cell1
+ 4 chars: m_chars
+ : init ( inst class -- )
+ locals| class inst |
+ 0 inst class --> m_cell1 !
+ inst class --> m_chars 4 0 fill
+ ." initializing an instance of c_foo at " inst x. cr
+ ;
+end-class
+
+.( c-foo instance methods... ) cr
+c-foo --> new foo-instance
+cr
+foo-instance --> methods
+foo-instance --> pedigree
+cr
+foo-instance 2dup
+ --> methods
+ --> pedigree
+cr
+c-foo --> see init
+cr
+foo-instance --> class --> see init
diff --git a/test/prefix.fr b/test/prefix.fr
index 58c66ddbf452..491faddecf38 100644
--- a/test/prefix.fr
+++ b/test/prefix.fr
@@ -1,8 +1,8 @@
-: 0x { | old-base -- n }
- base @ to old-base
- 16 base !
- 0 0 parse-word >number 2drop drop
- old-base base !
-;
-
+: 0x { | old-base -- n }
+ base @ to old-base
+ 16 base !
+ 0 0 parse-word >number 2drop drop
+ old-base base !
+;
+
\ No newline at end of file
diff --git a/test/sarray.fr b/test/sarray.fr
index 5793af1e5e82..b2672c56a1c6 100644
--- a/test/sarray.fr
+++ b/test/sarray.fr
@@ -1,17 +1,17 @@
-\ test file for ficl
-\ string array...
-: $array ( caddr u ... caddr u n -- )
- create 0 ?do , , loop
- does> swap 2* cells + 2@ type
-;
-
-: s
- s" string 3"
- s" string 2"
- s" string 1"
- s" string 0"
- 4
-;
-
-s $array s
-
+\ test file for ficl
+\ string array...
+: $array ( caddr u ... caddr u n -- )
+ create 0 ?do , , loop
+ does> swap 2* cells + 2@ type
+;
+
+: s
+ s" string 3"
+ s" string 2"
+ s" string 1"
+ s" string 0"
+ 4
+;
+
+s $array s
+
diff --git a/test/testcase.fr b/test/testcase.fr
index 13775d20a99c..9e3f260b130a 100644
--- a/test/testcase.fr
+++ b/test/testcase.fr
@@ -1,83 +1,84 @@
-
-
-1 2 3
-.s
-
-: test-case ( n -- )
- case
- 0 of
- ." zero"
- endof
- 1 of
- ." one"
- endof
- ." something else"
- endcase
- cr
- ;
-
-
-see test-case
-
-.( You should see 1 2 3 ->)
-.s
-.( <-) cr
-
-.( You should see "zero": )
-0 test-case
-
-.( You should see "one": )
-1 test-case
-
-.( You should see "something else": )
-324 test-case
-
-.( You should still see 1 2 3 ->)
-.s
-.( <-) cr
-
-
-: test-case-2 ( n -- )
- case
- 0 of
- ." zero"
- fallthrough
- 1 of
- ." one"
- endof
- 2 of
- ." two"
- fallthrough
- ." something else"
- endcase
- cr
- ;
-
-
-see test-case-2
-
-cr
-
-.( You should once more see 1 2 3 ->)
-.s
-.( <-) cr
-
-.( You should see "zeroone": )
-0 test-case-2
-
-.( You should see "one": )
-1 test-case-2
-
-.( You should see "two": )
-2 test-case-2
-
-.( You should see "something else": )
-324 test-case-2
-
-.( You should still see 1 2 3 ->)
-.s
-.( <-) cr
-
-
-
-bye
+
+
+1 2 3
+.s-simple
+cr
+
+: test-case ( n -- )
+ case
+ 0 of
+ ." zero"
+ endof
+ 1 of
+ ." one"
+ endof
+ ." something else"
+ endcase
+ cr
+ ;
+
+
+see test-case
+
+.( You should see [3] 1 2 3 -> )
+.s-simple
+.( <-) cr
+
+.( You should see "zero": )
+0 test-case
+
+.( You should see "one": )
+1 test-case
+
+.( You should see "something else": )
+324 test-case
+
+.( You should still see [3] 1 2 3 -> )
+.s-simple
+.( <-) cr
+
+
+: test-case-2 ( n -- )
+ case
+ 0 of
+ ." zero"
+ fallthrough
+ 1 of
+ ." one"
+ endof
+ 2 of
+ ." two"
+ fallthrough
+ ." something else"
+ endcase
+ cr
+ ;
+
+
+see test-case-2
+
+cr
+
+.( You should once more see [3] 1 2 3 -> )
+.s-simple
+.( <-) cr
+
+.( You should see "zeroone": )
+0 test-case-2
+
+.( You should see "one": )
+1 test-case-2
+
+.( You should see "two": )
+2 test-case-2
+
+.( You should see "something else": )
+324 test-case-2
+
+.( You should still see [3] 1 2 3 -> )
+.s-simple
+.( <-) cr
+
+
+
+bye
diff --git a/test/tester.fr b/test/tester.fr
index 6e239fb049dc..432b892cdfd0 100644
--- a/test/tester.fr
+++ b/test/tester.fr
@@ -1,59 +1,59 @@
-\ From: John Hayes S1I
-\ Subject: tester.fr
-\ Date: Mon, 27 Nov 95 13:10:09 PST
-\ john.hayes@jhuapl.edu
-\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
-\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
-\ VERSION 1.1
-
-\ jws notes: <> is a core ext word
-
-HEX
-
-\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
-\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
-VARIABLE VERBOSE
- TRUE VERBOSE !
-
-: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
- DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
-
-: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
- \ THE LINE THAT HAD THE ERROR.
- TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
- EMPTY-STACK \ THROW AWAY EVERY THING ELSE
- break \ jws
-;
-
-VARIABLE ACTUAL-DEPTH \ STACK RECORD
-
-CREATE ACTUAL-RESULTS 20 CELLS ALLOT
-
-: { \ ( -- ) SYNTACTIC SUGAR.
- ;
-
-: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
- DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
- ?DUP IF \ IF THERE IS SOMETHING ON STACK
- 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
- THEN ;
-
-: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
- \ (ACTUAL) CONTENTS.
- DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
- DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK
- 0 DO \ FOR EACH STACK ITEM
- ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
- <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
- LOOP
- THEN
- ELSE \ DEPTH MISMATCH
- S" WRONG NUMBER OF RESULTS: " ERROR
- THEN ;
-
-: TESTING \ ( -- ) TALKING COMMENT.
- SOURCE VERBOSE @
- IF DUP >R TYPE CR R> >IN !
- ELSE >IN ! DROP
- THEN ;
-
+\ From: John Hayes S1I
+\ Subject: tester.fr
+\ Date: Mon, 27 Nov 95 13:10:09 PST
+\ john.hayes@jhuapl.edu
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.1
+
+\ jws notes: <> is a core ext word
+
+HEX
+
+\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
+\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
+VARIABLE VERBOSE
+ TRUE VERBOSE !
+
+: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
+ DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
+
+: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
+ \ THE LINE THAT HAD THE ERROR.
+ TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR
+ EMPTY-STACK \ THROW AWAY EVERY THING ELSE
+ break \ jws
+;
+
+VARIABLE ACTUAL-DEPTH \ STACK RECORD
+
+CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+
+: { \ ( -- ) SYNTACTIC SUGAR.
+ ;
+
+: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
+ DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
+ ?DUP IF \ IF THERE IS SOMETHING ON STACK
+ 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
+ THEN ;
+
+: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
+ \ (ACTUAL) CONTENTS.
+ DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
+ DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK
+ 0 DO \ FOR EACH STACK ITEM
+ ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
+ <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
+ LOOP
+ THEN
+ ELSE \ DEPTH MISMATCH
+ S" WRONG NUMBER OF RESULTS: " ERROR
+ THEN ;
+
+: TESTING \ ( -- ) TALKING COMMENT.
+ SOURCE VERBOSE @
+ IF DUP >R TYPE CR R> >IN !
+ ELSE >IN ! DROP
+ THEN ;
+
diff --git a/test/vocab.fr b/test/vocab.fr
index 538257c37a79..cc989d77509a 100644
--- a/test/vocab.fr
+++ b/test/vocab.fr
@@ -1,32 +1,32 @@
-\ Here is an implementation of ALSO/ONLY in terms of the
-\ primitive search-order word set.
-\
-WORDLIST CONSTANT ROOT ROOT SET-CURRENT
-
-: DO-VOCABULARY ( -- ) \ Implementation factor
- DOES> @ >R ( ) ( R: widnew )
- GET-ORDER SWAP DROP ( wid1 ... widn-1 n )
- R> SWAP SET-ORDER
-;
-
-: DISCARD ( x1 .. xu u - ) \ Implementation factor
- 0 ?DO DROP LOOP \ DROP u+1 stack items
-;
-
-CREATE FORTH FORTH-WORDLIST , DO-VOCABULARY
-
-: VOCABULARY ( name -- ) WORDLIST CREATE , DO-VOCABULARY ;
-
-: ALSO ( -- ) GET-ORDER OVER SWAP 1+ SET-ORDER ;
-
-: PREVIOUS ( -- ) GET-ORDER SWAP DROP 1- SET-ORDER ;
-
-: DEFINITIONS ( -- ) GET-ORDER OVER SET-CURRENT DISCARD ;
-
-: ONLY ( -- ) ROOT ROOT 2 SET-ORDER ;
-
-\ Forth-83 version; just removes ONLY
-: SEAL ( -- ) GET-ORDER 1- SET-ORDER DROP ;
-
-\ F83 and F-PC version; leaves only CONTEXT
-: SEAL ( -- ) GET-ORDER OVER 1 SET-ORDER DISCARD ;
+\ Here is an implementation of ALSO/ONLY in terms of the
+\ primitive search-order word set.
+\
+WORDLIST CONSTANT ROOT ROOT SET-CURRENT
+
+: DO-VOCABULARY ( -- ) \ Implementation factor
+ DOES> @ >R ( ) ( R: widnew )
+ GET-ORDER SWAP DROP ( wid1 ... widn-1 n )
+ R> SWAP SET-ORDER
+;
+
+: DISCARD ( x1 .. xu u - ) \ Implementation factor
+ 0 ?DO DROP LOOP \ DROP u+1 stack items
+;
+
+CREATE FORTH FORTH-WORDLIST , DO-VOCABULARY
+
+: VOCABULARY ( name -- ) WORDLIST CREATE , DO-VOCABULARY ;
+
+: ALSO ( -- ) GET-ORDER OVER SWAP 1+ SET-ORDER ;
+
+: PREVIOUS ( -- ) GET-ORDER SWAP DROP 1- SET-ORDER ;
+
+: DEFINITIONS ( -- ) GET-ORDER OVER SET-CURRENT DISCARD ;
+
+: ONLY ( -- ) ROOT ROOT 2 SET-ORDER ;
+
+\ Forth-83 version; just removes ONLY
+: SEAL ( -- ) GET-ORDER 1- SET-ORDER DROP ;
+
+\ F83 and F-PC version; leaves only CONTEXT
+: SEAL ( -- ) GET-ORDER OVER 1 SET-ORDER DISCARD ;
diff --git a/testmain.c b/testmain.c
deleted file mode 100644
index e41f77cea47c..000000000000
--- a/testmain.c
+++ /dev/null
@@ -1,367 +0,0 @@
-/*
-** stub main for testing FICL under Win32
-** $Id: testmain.c,v 1.11 2001-10-28 10:59:19-08 jsadler Exp jsadler $
-*/
-/*
-** 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
-** 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 <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <time.h>
-#if defined (_WIN32)
-#include <direct.h>
-#endif
-#include <sys/types.h>
-#include <sys/stat.h>
-#ifdef linux
-#include <unistd.h>
-#endif
-
-#include "ficl.h"
-
-/*
-** Ficl interface to _getcwd (Win32)
-** Prints the current working directory using the VM's
-** textOut method...
-*/
-static void ficlGetCWD(FICL_VM *pVM)
-{
- char *cp;
-
-#if defined (_WIN32)
- cp = _getcwd(NULL, 80);
-#else
- cp = getcwd(NULL, 80);
-#endif
- vmTextOut(pVM, cp, 1);
- free(cp);
- return;
-}
-
-/*
-** Ficl interface to _chdir (Win32)
-** Gets a newline (or NULL) delimited string from the input
-** and feeds it to the Win32 chdir function...
-** Example:
-** cd c:\tmp
-*/
-static void ficlChDir(FICL_VM *pVM)
-{
- FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
- vmGetString(pVM, pFS, '\n');
- if (pFS->count > 0)
- {
- int err = chdir(pFS->text);
- if (err)
- {
- vmTextOut(pVM, "Error: path not found", 1);
- vmThrow(pVM, VM_QUIT);
- }
- }
- else
- {
- vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
- }
- return;
-}
-
-/*
-** Ficl interface to system (ANSI)
-** Gets a newline (or NULL) delimited string from the input
-** and feeds it to the Win32 system function...
-** Example:
-** system del *.*
-** \ ouch!
-*/
-static void ficlSystem(FICL_VM *pVM)
-{
- FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
-
- vmGetString(pVM, pFS, '\n');
- if (pFS->count > 0)
- {
- int err = system(pFS->text);
- if (err)
- {
- sprintf(pVM->pad, "System call returned %d", err);
- vmTextOut(pVM, pVM->pad, 1);
- vmThrow(pVM, VM_QUIT);
- }
- }
- else
- {
- vmTextOut(pVM, "Warning (system): nothing happened", 1);
- }
- return;
-}
-
-/*
-** Ficl add-in to load a text file and execute it...
-** Cheesy, but illustrative.
-** Line oriented... filename is newline (or NULL) delimited.
-** Example:
-** load test.ficl
-*/
-#define nLINEBUF 256
-static void ficlLoad(FICL_VM *pVM)
-{
- char cp[nLINEBUF];
- char filename[nLINEBUF];
- FICL_STRING *pFilename = (FICL_STRING *)filename;
- int nLine = 0;
- FILE *fp;
- int result;
- CELL id;
- struct stat buf;
-
-
- vmGetString(pVM, pFilename, '\n');
-
- if (pFilename->count <= 0)
- {
- vmTextOut(pVM, "Warning (load): nothing happened", 1);
- return;
- }
-
- /*
- ** get the file's size and make sure it exists
- */
- result = stat( pFilename->text, &buf );
-
- if (result != 0)
- {
- vmTextOut(pVM, "Unable to stat file: ", 0);
- vmTextOut(pVM, pFilename->text, 1);
- vmThrow(pVM, VM_QUIT);
- }
-
- fp = fopen(pFilename->text, "r");
- if (!fp)
- {
- vmTextOut(pVM, "Unable to open file ", 0);
- vmTextOut(pVM, pFilename->text, 1);
- vmThrow(pVM, VM_QUIT);
- }
-
- id = pVM->sourceID;
- pVM->sourceID.p = (void *)fp;
-
- /* feed each line to ficlExec */
- while (fgets(cp, nLINEBUF, fp))
- {
- int len = strlen(cp) - 1;
-
- nLine++;
- if (len <= 0)
- continue;
-
- if (cp[len] == '\n')
- cp[len] = '\0';
-
- result = ficlExec(pVM, cp);
- /* handle "bye" in loaded files. --lch */
- switch (result)
- {
- case VM_OUTOFTEXT:
- case VM_USEREXIT:
- break;
-
- default:
- pVM->sourceID = id;
- fclose(fp);
- vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
- break;
- }
- }
- /*
- ** 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;
- fclose(fp);
-
- /* handle "bye" in loaded files. --lch */
- if (result == VM_USEREXIT)
- vmThrow(pVM, VM_USEREXIT);
- return;
-}
-
-/*
-** Dump a tab delimited file that summarizes the contents of the
-** dictionary hash table by hashcode...
-*/
-static void spewHash(FICL_VM *pVM)
-{
- FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
- FICL_WORD *pFW;
- FILE *pOut;
- unsigned i;
- unsigned nHash = pHash->size;
-
- if (!vmGetWordToPad(pVM))
- vmThrow(pVM, VM_OUTOFTEXT);
-
- pOut = fopen(pVM->pad, "w");
- if (!pOut)
- {
- vmTextOut(pVM, "unable to open file", 1);
- return;
- }
-
- for (i=0; i < nHash; i++)
- {
- int n = 0;
-
- pFW = pHash->table[i];
- while (pFW)
- {
- n++;
- pFW = pFW->link;
- }
-
- fprintf(pOut, "%d\t%d", i, n);
-
- pFW = pHash->table[i];
- while (pFW)
- {
- fprintf(pOut, "\t%s", pFW->name);
- pFW = pFW->link;
- }
-
- fprintf(pOut, "\n");
- }
-
- fclose(pOut);
- return;
-}
-
-static void ficlBreak(FICL_VM *pVM)
-{
- pVM->state = pVM->state;
- return;
-}
-
-static void ficlClock(FICL_VM *pVM)
-{
- clock_t now = clock();
- stackPushUNS(pVM->pStack, (FICL_UNS)now);
- return;
-}
-
-static void clocksPerSec(FICL_VM *pVM)
-{
- stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
- return;
-}
-
-
-void buildTestInterface(FICL_SYSTEM *pSys)
-{
- ficlBuild(pSys, "break", ficlBreak, FW_DEFAULT);
- ficlBuild(pSys, "clock", ficlClock, FW_DEFAULT);
- ficlBuild(pSys, "cd", ficlChDir, FW_DEFAULT);
- ficlBuild(pSys, "load", ficlLoad, FW_DEFAULT);
- ficlBuild(pSys, "pwd", ficlGetCWD, FW_DEFAULT);
- ficlBuild(pSys, "system", ficlSystem, FW_DEFAULT);
- ficlBuild(pSys, "spewhash", spewHash, FW_DEFAULT);
- ficlBuild(pSys, "clocks/sec",
- clocksPerSec, FW_DEFAULT);
-
- return;
-}
-
-
-#if !defined (_WINDOWS)
-#define nINBUF 256
-
-#if !defined (_WIN32)
-#define __try
-#define __except(i) if (0)
-#endif
-
-int main(int argc, char **argv)
-{
- int ret = 0;
- char in[nINBUF];
- FICL_VM *pVM;
- FICL_SYSTEM *pSys;
-
- pSys = ficlInitSystem(10000);
- buildTestInterface(pSys);
- pVM = ficlNewVM(pSys);
-
- ret = ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
-
- /*
- ** load file from cmd line...
- */
- if (argc > 1)
- {
- sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
- __try
- {
- ret = ficlEvaluate(pVM, in);
- }
- __except(1)
- {
- vmTextOut(pVM, "exception -- cleaning up", 1);
- vmReset(pVM);
- }
- }
-
- while (ret != VM_USEREXIT)
- {
- fgets(in, nINBUF, stdin);
- __try
- {
- ret = ficlExec(pVM, in);
- }
- __except(1)
- {
- vmTextOut(pVM, "exception -- cleaning up", 1);
- vmReset(pVM);
- }
- }
-
- ficlTermSystem(pSys);
- return 0;
-}
-
-#endif
-
diff --git a/tools.c b/tools.c
index ad734e4b8834..3fd65bb89d2a 100644
--- 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.11 2001-12-04 17:58:14-08 jsadler Exp jsadler $
+** $Id: tools.c,v 1.12 2010/08/12 13:57:22 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -11,9 +11,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -46,7 +46,7 @@
** are the CFAs of colon definitions, constants, variables, DOES>
** words, and so on. It gets this information from a table and supporting
** functions in words.c.
-** colonParen doDoes createParen variableParen userParen constantParen
+** fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen
**
** Step and break debugger for Ficl
** debug ( xt -- ) Start debugging an xt
@@ -61,14 +61,33 @@
#include "ficl.h"
-#if 0
-/*
-** nBREAKPOINTS sizes the breakpoint array. One breakpoint (bp 0) is reserved
-** for the STEP command. The rest are user programmable.
-*/
-#define nBREAKPOINTS 32
+static void ficlPrimitiveStepIn(ficlVm *vm);
+static void ficlPrimitiveStepOver(ficlVm *vm);
+static void ficlPrimitiveStepBreak(ficlVm *vm);
+
+
+
+void ficlCallbackAssert(ficlCallback *callback, int expression, char *expressionString, char *filename, int line)
+#if FICL_ROBUST >= 1
+{
+ if (!expression)
+ {
+ static char buffer[256];
+ sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n", filename, line, expressionString);
+ ficlCallbackTextOut(callback, buffer);
+ exit(-1);
+ }
+}
+#else /* FICL_ROBUST >= 1 */
+{
+ FICL_IGNORE(callback);
+ FICL_IGNORE(expression);
+ FICL_IGNORE(expressionString);
+ FICL_IGNORE(filename);
+ FICL_IGNORE(line);
+}
+#endif /* FICL_ROBUST >= 1 */
-#endif
/**************************************************************************
@@ -76,213 +95,112 @@
** Set a breakpoint at the current value of IP by
** storing that address in a BREAKPOINT record
**************************************************************************/
-static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
+static void ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP)
{
- FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
- assert(pStep);
+ ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
+ FICL_VM_ASSERT(vm, pStep);
- pBP->address = pVM->ip;
- pBP->origXT = *pVM->ip;
- *pVM->ip = pStep;
+ pBP->address = vm->ip;
+ pBP->oldXT = *vm->ip;
+ *vm->ip = pStep;
}
/**************************************************************************
** d e b u g P r o m p t
**************************************************************************/
-static void debugPrompt(FICL_VM *pVM)
+static void ficlDebugPrompt(ficlVm *vm)
{
- vmTextOut(pVM, "dbg> ", 0);
-}
-
-
-/**************************************************************************
-** i s A F i c l W o r d
-** Vet a candidate pointer carefully to make sure
-** it's not some chunk o' inline data...
-** It has to have a name, and it has to look
-** like it's in the dictionary address range.
-** NOTE: this excludes :noname words!
-**************************************************************************/
-int isAFiclWord(FICL_DICT *pd, FICL_WORD *pFW)
-{
-
- if (!dictIncludes(pd, pFW))
- return 0;
-
- if (!dictIncludes(pd, pFW->name))
- return 0;
-
- if ((pFW->link != NULL) && !dictIncludes(pd, pFW->link))
- return 0;
-
- if ((pFW->nName <= 0) || (pFW->name[pFW->nName] != '\0'))
- return 0;
-
- if (strlen(pFW->name) != pFW->nName)
- return 0;
-
- return 1;
+ ficlVmTextOut(vm, "dbg> ");
}
#if 0
-static int isPrimitive(FICL_WORD *pFW)
+static int isPrimitive(ficlWord *word)
{
- WORDKIND wk = ficlWordClassify(pFW);
+ ficlWordKind wk = ficlWordClassify(word);
return ((wk != COLON) && (wk != DOES));
}
#endif
/**************************************************************************
- f i n d E n c l o s i n g W o r d
-** Given a pointer to something, check to make sure it's an address in the
-** dictionary. If so, search backwards until we find something that looks
-** like a dictionary header. If successful, return the address of the
-** FICL_WORD found. Otherwise return NULL.
-** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
+ d i c t H a s h S u m m a r y
+** Calculate a figure of merit for the dictionary hash table based
+** on the average search depth for all the words in the dictionary,
+** assuming uniform distribution of target keys. The figure of merit
+** is the ratio of the total search depth for all keys in the table
+** versus a theoretical optimum that would be achieved if the keys
+** were distributed into the table as evenly as possible.
+** The figure would be worse if the hash table used an open
+** addressing scheme (i.e. collisions resolved by searching the
+** table for an empty slot) for a given size table.
**************************************************************************/
-#define nSEARCH_CELLS 100
-
-static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
+#if FICL_WANT_FLOAT
+void ficlPrimitiveHashSummary(ficlVm *vm)
{
- FICL_WORD *pFW;
- FICL_DICT *pd = vmGetDict(pVM);
- int i;
-
- if (!dictIncludes(pd, (void *)cp))
- return NULL;
-
- for (i = nSEARCH_CELLS; i > 0; --i, --cp)
- {
- pFW = (FICL_WORD *)(cp + 1 - (sizeof (FICL_WORD) / sizeof (CELL)));
- if (isAFiclWord(pd, pFW))
- return pFW;
- }
-
- return NULL;
-}
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *pFHash;
+ ficlWord **hash;
+ unsigned size;
+ ficlWord *word;
+ unsigned i;
+ int nMax = 0;
+ int nWords = 0;
+ int nFilled;
+ double avg = 0.0;
+ double best;
+ int nAvg, nRem, nDepth;
+ FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
-/**************************************************************************
- s e e
-** TOOLS ( "<spaces>name" -- )
-** Display a human-readable representation of the named word's definition.
-** The source of the representation (object-code decompilation, source
-** block, etc.) and the particular form of the display is implementation
-** defined.
-**************************************************************************/
-/*
-** seeColon (for proctologists only)
-** Walks a colon definition, decompiling
-** on the fly. Knows about primitive control structures.
-*/
-static void seeColon(FICL_VM *pVM, CELL *pc)
-{
- char *cp;
- CELL *param0 = pc;
- FICL_DICT *pd = vmGetDict(pVM);
- FICL_WORD *pSemiParen = ficlLookup(pVM->pSys, "(;)");
- assert(pSemiParen);
+ pFHash = dictionary->wordlists[dictionary->wordlistCount - 1];
+ hash = pFHash->table;
+ size = pFHash->size;
+ nFilled = size;
- for (; pc->p != pSemiParen; pc++)
+ for (i = 0; i < size; i++)
{
- FICL_WORD *pFW = (FICL_WORD *)(pc->p);
-
- cp = pVM->pad;
- if ((void *)pc == (void *)pVM->ip)
- *cp++ = '>';
- else
- *cp++ = ' ';
- cp += sprintf(cp, "%3d ", pc-param0);
-
- if (isAFiclWord(pd, pFW))
- {
- WORDKIND kind = ficlWordClassify(pFW);
- CELL c;
+ int n = 0;
+ word = hash[i];
- switch (kind)
- {
- case LITERAL:
- c = *++pc;
- if (isAFiclWord(pd, c.p))
- {
- FICL_WORD *pLit = (FICL_WORD *)c.p;
- sprintf(cp, "%.*s ( %#lx literal )",
- pLit->nName, pLit->name, c.u);
- }
- else
- sprintf(cp, "literal %ld (%#lx)", c.i, c.u);
- break;
- case STRINGLIT:
- {
- FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
- pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
- 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)
- sprintf(cp, "if / while (branch %d)", pc+c.i-param0);
- else
- sprintf(cp, "until (branch %d)", pc+c.i-param0);
- break;
- case BRANCH:
- c = *++pc;
- 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, "endof (branch %d)", pc+c.i-param0);
- break;
-
- case OF:
- c = *++pc;
- sprintf(cp, "of (branch %d)", pc+c.i-param0);
- break;
-
- case QDO:
- c = *++pc;
- sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0);
- break;
- case DO:
- c = *++pc;
- sprintf(cp, "do (leave %d)", (CELL *)c.p-param0);
- break;
- case LOOP:
- c = *++pc;
- sprintf(cp, "loop (branch %d)", pc+c.i-param0);
- break;
- case PLOOP:
- c = *++pc;
- sprintf(cp, "+loop (branch %d)", pc+c.i-param0);
- break;
- default:
- sprintf(cp, "%.*s", pFW->nName, pFW->name);
- break;
- }
-
- }
- else /* probably not a word - punt and print value */
+ while (word)
{
- sprintf(cp, "%ld ( %#lx )", pc->i, pc->u);
+ ++n;
+ ++nWords;
+ word = word->link;
}
- vmTextOut(pVM, pVM->pad, 1);
+ avg += (double)(n * (n+1)) / 2.0;
+
+ if (n > nMax)
+ nMax = n;
+ if (n == 0)
+ --nFilled;
}
- vmTextOut(pVM, ";", 1);
+ /* Calc actual avg search depth for this hash */
+ avg = avg / nWords;
+
+ /* Calc best possible performance with this size hash */
+ nAvg = nWords / size;
+ nRem = nWords % size;
+ nDepth = size * (nAvg * (nAvg+1))/2 + (nAvg+1)*nRem;
+ best = (double)nDepth/nWords;
+
+ sprintf(vm->pad,
+ "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n",
+ size,
+ (double)nFilled * 100.0 / size, nMax,
+ avg,
+ best,
+ 100.0 * best / avg);
+
+ ficlVmTextOut(vm, vm->pad);
+
+ return;
}
+#endif
/*
** Here's the outer part of the decompiler. It's
@@ -292,71 +210,77 @@ static void seeColon(FICL_VM *pVM, CELL *pc)
** something appropriate. If the CFA is not recognized,
** just indicate that it is a primitive.
*/
-static void seeXT(FICL_VM *pVM)
+static void ficlPrimitiveSeeXT(ficlVm *vm)
{
- FICL_WORD *pFW;
- WORDKIND kind;
+ ficlWord *word;
+ ficlWordKind kind;
- pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
- kind = ficlWordClassify(pFW);
+ word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
+ kind = ficlWordClassify(word);
switch (kind)
{
- case COLON:
- sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
- vmTextOut(pVM, pVM->pad, 1);
- seeColon(pVM, pFW->param);
+ case FICL_WORDKIND_COLON:
+ sprintf(vm->pad, ": %.*s\n", word->length, word->name);
+ ficlVmTextOut(vm, vm->pad);
+ ficlDictionarySee(ficlVmGetDictionary(vm), word, &(vm->callback));
break;
- case DOES:
- vmTextOut(pVM, "does>", 1);
- seeColon(pVM, (CELL *)pFW->param->p);
+ case FICL_WORDKIND_DOES:
+ ficlVmTextOut(vm, "does>\n");
+ ficlDictionarySee(ficlVmGetDictionary(vm), (ficlWord *)word->param->p, &(vm->callback));
break;
- case CREATE:
- vmTextOut(pVM, "create", 1);
+ case FICL_WORDKIND_CREATE:
+ ficlVmTextOut(vm, "create\n");
break;
- case VARIABLE:
- sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
- vmTextOut(pVM, pVM->pad, 1);
+ case FICL_WORDKIND_VARIABLE:
+ sprintf(vm->pad, "variable = %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
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);
+ case FICL_WORDKIND_USER:
+ sprintf(vm->pad, "user variable %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
break;
#endif
- case CONSTANT:
- sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
- vmTextOut(pVM, pVM->pad, 1);
+ case FICL_WORDKIND_CONSTANT:
+ sprintf(vm->pad, "constant = %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+
+ case FICL_WORDKIND_2CONSTANT:
+ sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n", word->param[1].i, word->param->i, word->param[1].u, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
default:
- sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
- vmTextOut(pVM, pVM->pad, 1);
+ sprintf(vm->pad, "%.*s is a primitive\n", word->length, word->name);
+ ficlVmTextOut(vm, vm->pad);
break;
}
- if (pFW->flags & FW_IMMEDIATE)
+ if (word->flags & FICL_WORD_IMMEDIATE)
{
- vmTextOut(pVM, "immediate", 1);
+ ficlVmTextOut(vm, "immediate\n");
}
- if (pFW->flags & FW_COMPILE)
+ if (word->flags & FICL_WORD_COMPILE_ONLY)
{
- vmTextOut(pVM, "compile-only", 1);
+ ficlVmTextOut(vm, "compile-only\n");
}
return;
}
-static void see(FICL_VM *pVM)
+static void ficlPrimitiveSee(ficlVm *vm)
{
- ficlTick(pVM);
- seeXT(pVM);
+ ficlPrimitiveTick(vm);
+ ficlPrimitiveSeeXT(vm);
return;
}
@@ -369,27 +293,27 @@ static void see(FICL_VM *pVM)
** set a breakpoint at its first instruction, and run to the breakpoint.
** Note: the semantics of this word are equivalent to "step in"
**************************************************************************/
-void ficlDebugXT(FICL_VM *pVM)
+static void ficlPrimitiveDebugXT(ficlVm *vm)
{
- FICL_WORD *xt = stackPopPtr(pVM->pStack);
- WORDKIND wk = ficlWordClassify(xt);
+ ficlWord *xt = ficlStackPopPointer(vm->dataStack);
+ ficlWordKind wk = ficlWordClassify(xt);
- stackPushPtr(pVM->pStack, xt);
- seeXT(pVM);
+ ficlStackPushPointer(vm->dataStack, xt);
+ ficlPrimitiveSeeXT(vm);
switch (wk)
{
- case COLON:
- case DOES:
+ case FICL_WORDKIND_COLON:
+ case FICL_WORDKIND_DOES:
/*
** Run the colon code and set a breakpoint at the next instruction
*/
- vmExecute(pVM, xt);
- vmSetBreak(pVM, &(pVM->pSys->bpStep));
+ ficlVmExecuteWord(vm, xt);
+ ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
break;
default:
- vmExecute(pVM, xt);
+ ficlVmExecuteWord(vm, xt);
break;
}
@@ -399,23 +323,21 @@ void ficlDebugXT(FICL_VM *pVM)
/**************************************************************************
s t e p I n
-** FICL
+** Ficl
** Execute the next instruction, stepping into it if it's a colon definition
** or a does> word. This is the easy kind of step.
**************************************************************************/
-void stepIn(FICL_VM *pVM)
+static void ficlPrimitiveStepIn(ficlVm *vm)
{
/*
** Do one step of the inner loop
*/
- {
- M_VM_STEP(pVM)
- }
+ ficlVmExecuteWord(vm, *vm->ip++);
/*
** Now set a breakpoint at the next instruction
*/
- vmSetBreak(pVM, &(pVM->pSys->bpStep));
+ ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
return;
}
@@ -423,36 +345,36 @@ void stepIn(FICL_VM *pVM)
/**************************************************************************
s t e p O v e r
-** FICL
+** Ficl
** Execute the next instruction atomically. This requires some insight into
** the memory layout of compiled code. Set a breakpoint at the next instruction
** in this word, and run until we hit it
**************************************************************************/
-void stepOver(FICL_VM *pVM)
+static void ficlPrimitiveStepOver(ficlVm *vm)
{
- FICL_WORD *pFW;
- WORDKIND kind;
- FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
- assert(pStep);
+ ficlWord *word;
+ ficlWordKind kind;
+ ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
+ FICL_VM_ASSERT(vm, pStep);
- pFW = *pVM->ip;
- kind = ficlWordClassify(pFW);
+ word = *vm->ip;
+ kind = ficlWordClassify(word);
switch (kind)
{
- case COLON:
- case DOES:
+ case FICL_WORDKIND_COLON:
+ case FICL_WORDKIND_DOES:
/*
- ** assume that the next cell holds an instruction
- ** set a breakpoint there and return to the inner interp
+ ** assume that the next ficlCell holds an instruction
+ ** set a breakpoint there and return to the inner interpreter
*/
- pVM->pSys->bpStep.address = pVM->ip + 1;
- pVM->pSys->bpStep.origXT = pVM->ip[1];
- pVM->ip[1] = pStep;
+ vm->callback.system->breakpoint.address = vm->ip + 1;
+ vm->callback.system->breakpoint.oldXT = vm->ip[1];
+ vm->ip[1] = pStep;
break;
default:
- stepIn(pVM);
+ ficlPrimitiveStepIn(vm);
break;
}
@@ -462,9 +384,9 @@ void stepOver(FICL_VM *pVM)
/**************************************************************************
s t e p - b r e a k
-** FICL
+** Ficl
** Handles breakpoints for stepped execution.
-** Upon entry, bpStep contains the address and replaced instruction
+** Upon entry, breakpoint contains the address and replaced instruction
** of the current breakpoint.
** Clear the breakpoint
** Get a command from the console.
@@ -476,118 +398,141 @@ void stepOver(FICL_VM *pVM)
** q (quit) - abort current word
** b (toggle breakpoint)
**************************************************************************/
-void stepBreak(FICL_VM *pVM)
+
+extern char *ficlDictionaryInstructionNames[];
+
+static void ficlPrimitiveStepBreak(ficlVm *vm)
{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_WORD *pOnStep;
+ ficlString command;
+ ficlWord *word;
+ ficlWord *pOnStep;
+ ficlWordKind kind;
- if (!pVM->fRestart)
+ if (!vm->restart)
{
- assert(pVM->pSys->bpStep.address);
- assert(pVM->pSys->bpStep.origXT);
+ FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address);
+ FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT);
/*
** Clear the breakpoint that caused me to run
** Restore the original instruction at the breakpoint,
** and restore the IP
*/
- pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
- *pVM->ip = pVM->pSys->bpStep.origXT;
+ vm->ip = (ficlIp)(vm->callback.system->breakpoint.address);
+ *vm->ip = vm->callback.system->breakpoint.oldXT;
/*
** If there's an onStep, do it
*/
- pOnStep = ficlLookup(pVM->pSys, "on-step");
+ pOnStep = ficlSystemLookup(vm->callback.system, "on-step");
if (pOnStep)
- ficlExecXT(pVM, pOnStep);
+ ficlVmExecuteXT(vm, pOnStep);
/*
** Print the name of the next instruction
*/
- pFW = pVM->pSys->bpStep.origXT;
- sprintf(pVM->pad, "next: %.*s", pFW->nName, pFW->name);
-#if 0
- if (isPrimitive(pFW))
- {
- strcat(pVM->pad, " ( primitive )");
- }
-#endif
+ word = vm->callback.system->breakpoint.oldXT;
- vmTextOut(pVM, pVM->pad, 1);
- debugPrompt(pVM);
- }
- else
- {
- pVM->fRestart = 0;
- }
-
- si = vmGetWord(pVM);
+ kind = ficlWordClassify(word);
- if (!strincmp(si.cp, "i", si.count))
- {
- stepIn(pVM);
- }
- else if (!strincmp(si.cp, "g", si.count))
- {
- return;
- }
- else if (!strincmp(si.cp, "l", si.count))
- {
- FICL_WORD *xt;
- xt = findEnclosingWord(pVM, (CELL *)(pVM->ip));
- if (xt)
+ switch (kind)
{
- stackPushPtr(pVM->pStack, xt);
- seeXT(pVM);
- }
- else
- {
- vmTextOut(pVM, "sorry - can't do that", 1);
- }
- vmThrow(pVM, VM_RESTART);
- }
- else if (!strincmp(si.cp, "o", si.count))
- {
- stepOver(pVM);
- }
- else if (!strincmp(si.cp, "q", si.count))
- {
- ficlTextOut(pVM, FICL_PROMPT, 0);
- vmThrow(pVM, VM_ABORT);
- }
- else if (!strincmp(si.cp, "x", si.count))
- {
- /*
- ** Take whatever's left in the TIB and feed it to a subordinate ficlExec
- */
- int ret;
- char *cp = pVM->tib.cp + pVM->tib.index;
- int count = pVM->tib.end - cp;
- FICL_WORD *oldRun = pVM->runningWord;
-
- ret = ficlExecC(pVM, cp, count);
-
- if (ret == VM_OUTOFTEXT)
- {
- ret = VM_RESTART;
- pVM->runningWord = oldRun;
- vmTextOut(pVM, "", 1);
- }
-
- vmThrow(pVM, ret);
+ case FICL_WORDKIND_INSTRUCTION:
+ case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
+ sprintf(vm->pad, "next: %s (instruction %ld)\n", ficlDictionaryInstructionNames[(long)word], (long)word);
+ break;
+ default:
+ sprintf(vm->pad, "next: %s\n", word->name);
+ break;
+ }
+
+ ficlVmTextOut(vm, vm->pad);
+ ficlDebugPrompt(vm);
}
else
{
- vmTextOut(pVM, "i -- step In", 1);
- vmTextOut(pVM, "o -- step Over", 1);
- vmTextOut(pVM, "g -- Go (execute to completion)", 1);
- vmTextOut(pVM, "l -- List source code", 1);
- vmTextOut(pVM, "q -- Quit (stop debugging and abort)", 1);
- vmTextOut(pVM, "x -- eXecute the rest of the line as ficl words", 1);
- debugPrompt(pVM);
- vmThrow(pVM, VM_RESTART);
+ vm->restart = 0;
}
+ command = ficlVmGetWord(vm);
+
+ switch (command.text[0])
+ {
+ case 'i':
+ ficlPrimitiveStepIn(vm);
+ break;
+
+ case 'o':
+ ficlPrimitiveStepOver(vm);
+ break;
+
+ case 'g':
+ break;
+
+ case 'l':
+ {
+ ficlWord *xt;
+ xt = ficlDictionaryFindEnclosingWord(ficlVmGetDictionary(vm), (ficlCell *)(vm->ip));
+ if (xt)
+ {
+ ficlStackPushPointer(vm->dataStack, xt);
+ ficlPrimitiveSeeXT(vm);
+ }
+ else
+ {
+ ficlVmTextOut(vm, "sorry - can't do that\n");
+ }
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+ break;
+ }
+
+ case 'q':
+ {
+ ficlVmTextOut(vm, FICL_PROMPT);
+ ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
+ break;
+ }
+
+ case 'x':
+ {
+ /*
+ ** Take whatever's left in the TIB and feed it to a subordinate ficlVmExecuteString
+ */
+ int returnValue;
+ ficlString s;
+ ficlWord *oldRunningWord = vm->runningWord;
+
+ FICL_STRING_SET_POINTER(s, vm->tib.text + vm->tib.index);
+ FICL_STRING_SET_LENGTH(s, vm->tib.end - FICL_STRING_GET_POINTER(s));
+
+ returnValue = ficlVmExecuteString(vm, s);
+
+ if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT)
+ {
+ returnValue = FICL_VM_STATUS_RESTART;
+ vm->runningWord = oldRunningWord;
+ ficlVmTextOut(vm, "\n");
+ }
+
+ ficlVmThrow(vm, returnValue);
+ break;
+ }
+
+ default:
+ {
+ ficlVmTextOut(vm,
+ "i -- step In\n"
+ "o -- step Over\n"
+ "g -- Go (execute to completion)\n"
+ "l -- List source code\n"
+ "q -- Quit (stop debugging and abort)\n"
+ "x -- eXecute the rest of the line as Ficl words\n"
+ );
+ ficlDebugPrompt(vm);
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+ break;
+ }
+ }
+
return;
}
@@ -598,9 +543,9 @@ void stepBreak(FICL_VM *pVM)
** Signal the system to shut down - this causes ficlExec to return
** VM_USEREXIT. The rest is up to you.
**************************************************************************/
-static void bye(FICL_VM *pVM)
+static void ficlPrimitiveBye(ficlVm *vm)
{
- vmThrow(pVM, VM_USEREXIT);
+ ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
return;
}
@@ -610,85 +555,141 @@ static void bye(FICL_VM *pVM)
** TOOLS
** Display the parameter stack (code for ".s")
**************************************************************************/
-static void displayPStack(FICL_VM *pVM)
+
+struct stackContext
{
- FICL_STACK *pStk = pVM->pStack;
- int d = stackDepth(pStk);
- int i;
- CELL *pCell;
+ ficlVm *vm;
+ ficlDictionary *dictionary;
+ int count;
+};
- vmCheckStack(pVM, 0, 0);
+static ficlInteger ficlStackDisplayCallback(void *c, ficlCell *cell)
+{
+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[64];
+ sprintf(buffer, "[0x%08x %3d]: %12d (0x%08x)\n", cell, context->count++, cell->i, cell->i);
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
- if (d == 0)
- vmTextOut(pVM, "(Stack Empty) ", 0);
- else
+void ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, void *context)
+{
+ ficlVm *vm = stack->vm;
+ char buffer[128];
+ struct stackContext myContext;
+
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n", stack->name, ficlStackDepth(stack), stack->top);
+ ficlVmTextOut(vm, buffer);
+
+ if (callback == NULL)
{
- pCell = pStk->base;
- for (i = 0; i < d; i++)
- {
- vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
- vmTextOut(pVM, " ", 0);
- }
+ myContext.vm = vm;
+ myContext.count = 0;
+ context = &myContext;
+ callback = ficlStackDisplayCallback;
}
+ ficlStackWalk(stack, callback, context, FICL_FALSE);
+
+ sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name, stack->base);
+ ficlVmTextOut(vm, buffer);
+
return;
}
-static void displayRStack(FICL_VM *pVM)
+void ficlVmDisplayDataStack(ficlVm *vm)
{
- FICL_STACK *pStk = pVM->rStack;
- int d = stackDepth(pStk);
- int i;
- CELL *pCell;
- FICL_DICT *dp = vmGetDict(pVM);
+ ficlStackDisplay(vm->dataStack, NULL, NULL);
+ return;
+}
- vmCheckStack(pVM, 0, 0);
- if (d == 0)
- vmTextOut(pVM, "(Stack Empty) ", 0);
- else
+
+
+static ficlInteger ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
+{
+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[32];
+ sprintf(buffer, "%s%d", context->count ? " " : "", cell->i);
+ context->count++;
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+
+void ficlVmDisplayDataStackSimple(ficlVm *vm)
+{
+ ficlStack *stack = vm->dataStack;
+ char buffer[32];
+ struct stackContext context;
+
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ sprintf(buffer, "[%d] ", ficlStackDepth(stack));
+ ficlVmTextOut(vm, buffer);
+
+ context.vm = vm;
+ context.count = 0;
+ ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context, FICL_TRUE);
+ return;
+}
+
+
+
+
+static ficlInteger ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
+{
+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[128];
+
+ sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", cell, context->count++, cell->i, cell->i);
+
+ /*
+ ** Attempt to find the word that contains the return
+ ** stack address (as if it is part of a colon definition).
+ ** If this works, also print the name of the word.
+ */
+ if (ficlDictionaryIncludes(context->dictionary, cell->p))
{
- pCell = pStk->base;
- for (i = 0; i < d; i++)
+ ficlWord *word = ficlDictionaryFindEnclosingWord(context->dictionary, cell->p);
+ if (word)
{
- CELL c = *pCell++;
- /*
- ** Attempt to find the word that contains the
- ** stacked address (as if it is part of a colon definition).
- ** If this works, print the name of the word. Otherwise print
- ** the value as a number.
- */
- if (dictIncludes(dp, c.p))
- {
- FICL_WORD *pFW = findEnclosingWord(pVM, c.p);
- if (pFW)
- {
- int offset = (CELL *)c.p - &pFW->param[0];
- sprintf(pVM->pad, "%s+%d ", pFW->name, offset);
- vmTextOut(pVM, pVM->pad, 0);
- continue; /* no need to print the numeric value */
- }
- }
- vmTextOut(pVM, ltoa(c.i, pVM->pad, pVM->base), 0);
- vmTextOut(pVM, " ", 0);
+ int offset = (ficlCell *)cell->p - &word->param[0];
+ sprintf(buffer + strlen(buffer), ", %s + %d ", word->name, offset);
}
}
+ strcat(buffer, "\n");
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+void ficlVmDisplayReturnStack(ficlVm *vm)
+{
+ struct stackContext context;
+ context.vm = vm;
+ context.count = 0;
+ context.dictionary = ficlVmGetDictionary(vm);
+ ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback, &context);
return;
}
+
+
/**************************************************************************
f o r g e t - w i d
**
**************************************************************************/
-static void forgetWid(FICL_VM *pVM)
+static void ficlPrimitiveForgetWid(ficlVm *vm)
{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_HASH *pHash;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash;
- pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
- hashForget(pHash, pDict->here);
+ hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
+ ficlHashForget(hash, dictionary->here);
return;
}
@@ -706,43 +707,43 @@ static void forgetWid(FICL_VM *pVM)
** compilation word list. An ambiguous condition exists if the
** compilation word list is deleted.
**************************************************************************/
-static void forget(FICL_VM *pVM)
+static void ficlPrimitiveForget(ficlVm *vm)
{
void *where;
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_HASH *pHash = pDict->pCompile;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash = dictionary->compilationWordlist;
- ficlTick(pVM);
- where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
- hashForget(pHash, where);
- pDict->here = PTRtoCELL where;
+ ficlPrimitiveTick(vm);
+ where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
+ ficlHashForget(hash, where);
+ dictionary->here = FICL_POINTER_TO_CELL(where);
return;
}
/**************************************************************************
- l i s t W o r d s
+ w o r d s
**
**************************************************************************/
#define nCOLWIDTH 8
-static void listWords(FICL_VM *pVM)
+static void ficlPrimitiveWords(ficlVm *vm)
{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
- FICL_WORD *wp;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
+ ficlWord *wp;
int nChars = 0;
int len;
unsigned i;
int nWords = 0;
char *cp;
- char *pPad = pVM->pad;
+ char *pPad = vm->pad;
- for (i = 0; i < pHash->size; i++)
+ for (i = 0; i < hash->size; i++)
{
- for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++)
{
- if (wp->nName == 0) /* ignore :noname defs */
+ if (wp->length == 0) /* ignore :noname defs */
continue;
cp = wp->name;
@@ -750,9 +751,10 @@ static void listWords(FICL_VM *pVM)
if (nChars > 70)
{
+ pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
- vmTextOut(pVM, pPad, 1);
+ ficlVmTextOut(vm, pPad);
}
else
{
@@ -763,23 +765,25 @@ static void listWords(FICL_VM *pVM)
if (nChars > 70)
{
+ pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
- vmTextOut(pVM, pPad, 1);
+ ficlVmTextOut(vm, pPad);
}
}
}
if (nChars > 0)
{
+ pPad[nChars++] = '\n';
pPad[nChars] = '\0';
nChars = 0;
- vmTextOut(pVM, pPad, 1);
+ ficlVmTextOut(vm, pPad);
}
- sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
- nWords, (long) (dp->here - dp->dict), dp->size);
- vmTextOut(pVM, pVM->pad, 1);
+ sprintf(vm->pad, "Dictionary: %d words, %ld cells used of %u total\n",
+ nWords, (long) (dictionary->here - dictionary->base), dictionary->size);
+ ficlVmTextOut(vm, vm->pad);
return;
}
@@ -788,60 +792,82 @@ static void listWords(FICL_VM *pVM)
l i s t E n v
** Print symbols defined in the environment
**************************************************************************/
-static void listEnv(FICL_VM *pVM)
+static void ficlPrimitiveListEnv(ficlVm *vm)
{
- FICL_DICT *dp = pVM->pSys->envp;
- FICL_HASH *pHash = dp->pForthWords;
- FICL_WORD *wp;
+ ficlDictionary *dictionary = vm->callback.system->environment;
+ ficlHash *hash = dictionary->forthWordlist;
+ ficlWord *word;
unsigned i;
- int nWords = 0;
+ int counter = 0;
- for (i = 0; i < pHash->size; i++)
+ for (i = 0; i < hash->size; i++)
{
- for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ for (word = hash->table[i]; word != NULL; word = word->link, counter++)
{
- vmTextOut(pVM, wp->name, 1);
+ ficlVmTextOut(vm, word->name);
+ ficlVmTextOut(vm, "\n");
}
}
- sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
- nWords, (long) (dp->here - dp->dict), dp->size);
- vmTextOut(pVM, pVM->pad, 1);
+ sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n",
+ counter, (long) (dictionary->here - dictionary->base), dictionary->size);
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+
+
+
+/*
+** This word lists the parse steps in order
+*/
+void ficlPrimitiveParseStepList(ficlVm *vm)
+{
+ int i;
+ ficlSystem *system = vm->callback.system;
+ FICL_VM_ASSERT(vm, system);
+
+ ficlVmTextOut(vm, "Parse steps:\n");
+ ficlVmTextOut(vm, "lookup\n");
+
+ for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
+ {
+ if (system->parseList[i] != NULL)
+ {
+ ficlVmTextOut(vm, system->parseList[i]->name);
+ ficlVmTextOut(vm, "\n");
+ }
+ else break;
+ }
return;
}
/**************************************************************************
e n v C o n s t a n t
-** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
+** Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl code to set
** environment constants...
**************************************************************************/
-static void envConstant(FICL_VM *pVM)
+static void ficlPrimitiveEnvConstant(ficlVm *vm)
{
unsigned value;
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- vmGetWordToPad(pVM);
- value = POPUNS();
- ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
+ ficlVmGetWordToPad(vm);
+ value = ficlStackPopUnsigned(vm->dataStack);
+ ficlDictionarySetConstant(ficlSystemGetEnvironment(vm->callback.system), vm->pad, (ficlUnsigned)value);
return;
}
-static void env2Constant(FICL_VM *pVM)
+static void ficlPrimitiveEnv2Constant(ficlVm *vm)
{
- unsigned v1, v2;
+ ficl2Integer value;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
- vmGetWordToPad(pVM);
- v2 = POPUNS();
- v1 = POPUNS();
- ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
+ ficlVmGetWordToPad(vm);
+ value = ficlStackPop2Integer(vm->dataStack);
+ ficlDictionarySet2Constant(ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
return;
}
@@ -851,42 +877,49 @@ static void env2Constant(FICL_VM *pVM)
** Builds wordset for debugger and TOOLS optional word set
**************************************************************************/
-void ficlCompileTools(FICL_SYSTEM *pSys)
+void ficlSystemCompileTools(ficlSystem *system)
{
- FICL_DICT *dp = pSys->dp;
- assert (dp);
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
/*
** TOOLS and TOOLS EXT
*/
- dictAppendWord(dp, ".s", displayPStack, FW_DEFAULT);
- dictAppendWord(dp, "bye", bye, FW_DEFAULT);
- dictAppendWord(dp, "forget", forget, FW_DEFAULT);
- dictAppendWord(dp, "see", see, FW_DEFAULT);
- dictAppendWord(dp, "words", listWords, FW_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".s-simple", ficlVmDisplayDataStackSimple, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords, FICL_WORD_DEFAULT);
/*
** Set TOOLS environment query values
*/
- ficlSetEnv(pSys, "tools", FICL_TRUE);
- ficlSetEnv(pSys, "tools-ext", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);
/*
** Ficl extras
*/
- dictAppendWord(dp, "r.s", displayRStack, FW_DEFAULT); /* guy carver */
- dictAppendWord(dp, ".env", listEnv, FW_DEFAULT);
- dictAppendWord(dp, "env-constant",
- envConstant, FW_DEFAULT);
- dictAppendWord(dp, "env-2constant",
- env2Constant, FW_DEFAULT);
- dictAppendWord(dp, "debug-xt", ficlDebugXT, FW_DEFAULT);
- dictAppendWord(dp, "parse-order",
- ficlListParseSteps,
- FW_DEFAULT);
- dictAppendWord(dp, "step-break",stepBreak, FW_DEFAULT);
- dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT);
- dictAppendWord(dp, "see-xt", seeXT, FW_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "r.s", ficlVmDisplayReturnStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".env", ficlPrimitiveListEnv, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "env-constant",
+ ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "env-2constant",
+ ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "debug-xt", ficlPrimitiveDebugXT, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "parse-order", ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "step-break",ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forget-wid",ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "see-xt", ficlPrimitiveSeeXT, FICL_WORD_DEFAULT);
+
+#if FICL_WANT_FLOAT
+ ficlDictionarySetPrimitive(dictionary, ".hash", ficlPrimitiveHashSummary,FICL_WORD_DEFAULT);
+#endif
return;
}
diff --git a/unix.c b/unix.c
deleted file mode 100644
index 3cf7862329b6..000000000000
--- a/unix.c
+++ /dev/null
@@ -1,21 +0,0 @@
-#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;
-}
-
-
diff --git a/utility.c b/utility.c
new file mode 100644
index 000000000000..0a9d2a0c7487
--- /dev/null
+++ b/utility.c
@@ -0,0 +1,262 @@
+#include <ctype.h>
+
+#include "ficl.h"
+
+
+/**************************************************************************
+ a l i g n P t r
+** Aligns the given pointer to FICL_ALIGN address units.
+** Returns the aligned pointer value.
+**************************************************************************/
+void *ficlAlignPointer(void *ptr)
+{
+#if FICL_PLATFORM_ALIGNMENT > 1
+ intptr_t p = (intptr_t)ptr;
+ if (p & (FICL_PLATFORM_ALIGNMENT - 1))
+ ptr = (void *)((p & ~(FICL_PLATFORM_ALIGNMENT - 1)) + FICL_PLATFORM_ALIGNMENT);
+#endif
+ return ptr;
+}
+
+
+/**************************************************************************
+ s t r r e v
+**
+**************************************************************************/
+char *ficlStringReverse( char *string )
+{ /* reverse a string in-place */
+ int i = strlen(string);
+ char *p1 = string; /* first char of string */
+ char *p2 = string + i - 1; /* last non-NULL char of string */
+ char c;
+
+ if (i > 1)
+ {
+ while (p1 < p2)
+ {
+ c = *p2;
+ *p2 = *p1;
+ *p1 = c;
+ p1++; p2--;
+ }
+ }
+
+ return string;
+}
+
+
+/**************************************************************************
+ d i g i t _ t o _ c h a r
+**
+**************************************************************************/
+static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+char ficlDigitToCharacter(int value)
+{
+ return digits[value];
+}
+
+
+/**************************************************************************
+ i s P o w e r O f T w o
+** Tests whether supplied argument is an integer power of 2 (2**n)
+** where 32 > n > 1, and returns n if so. Otherwise returns zero.
+**************************************************************************/
+int ficlIsPowerOfTwo(ficlUnsigned u)
+{
+ int i = 1;
+ ficlUnsigned t = 2;
+
+ for (; ((t <= u) && (t != 0)); i++, t <<= 1)
+ {
+ if (u == t)
+ return i;
+ }
+
+ return 0;
+}
+
+
+/**************************************************************************
+ l t o a
+**
+**************************************************************************/
+char *ficlLtoa( ficlInteger value, char *string, int radix )
+{ /* convert long to string, any base */
+ char *cp = string;
+ int sign = ((radix == 10) && (value < 0));
+ int pwr;
+
+ FICL_ASSERT(NULL, radix > 1);
+ FICL_ASSERT(NULL, radix < 37);
+ FICL_ASSERT(NULL, string);
+
+ pwr = ficlIsPowerOfTwo((ficlUnsigned)radix);
+
+ if (sign)
+ value = -value;
+
+ if (value == 0)
+ *cp++ = '0';
+ else if (pwr != 0)
+ {
+ ficlUnsigned v = (ficlUnsigned) value;
+ ficlUnsigned mask = (ficlUnsigned) ~(-1 << pwr);
+ while (v)
+ {
+ *cp++ = digits[v & mask];
+ v >>= pwr;
+ }
+ }
+ else
+ {
+ ficl2UnsignedQR result;
+ ficl2Unsigned v;
+ FICL_UNSIGNED_TO_2UNSIGNED((ficlUnsigned)value, v);
+ while (FICL_2UNSIGNED_NOT_ZERO(v))
+ {
+ result = ficl2UnsignedDivide(v, (ficlUnsigned)radix);
+ *cp++ = digits[result.remainder];
+ v = result.quotient;
+ }
+ }
+
+ if (sign)
+ *cp++ = '-';
+
+ *cp++ = '\0';
+
+ return ficlStringReverse(string);
+}
+
+
+/**************************************************************************
+ u l t o a
+**
+**************************************************************************/
+char *ficlUltoa(ficlUnsigned value, char *string, int radix )
+{ /* convert long to string, any base */
+ char *cp = string;
+ ficl2Unsigned ud;
+ ficl2UnsignedQR result;
+
+ FICL_ASSERT(NULL, radix > 1);
+ FICL_ASSERT(NULL, radix < 37);
+ FICL_ASSERT(NULL, string);
+
+ if (value == 0)
+ *cp++ = '0';
+ else
+ {
+ FICL_UNSIGNED_TO_2UNSIGNED(value, ud);
+ while (FICL_2UNSIGNED_NOT_ZERO(ud))
+ {
+ result = ficl2UnsignedDivide(ud, (ficlUnsigned)radix);
+ ud = result.quotient;
+ *cp++ = digits[result.remainder];
+ }
+ }
+
+ *cp++ = '\0';
+
+ return ficlStringReverse(string);
+}
+
+
+/**************************************************************************
+ c a s e F o l d
+** Case folds a NULL terminated string in place. All characters
+** get converted to lower case.
+**************************************************************************/
+char *ficlStringCaseFold(char *cp)
+{
+ char *oldCp = cp;
+
+ while (*cp)
+ {
+ if (isupper((unsigned char)*cp))
+ *cp = (char)tolower((unsigned char)*cp);
+ cp++;
+ }
+
+ return oldCp;
+}
+
+
+/**************************************************************************
+ s t r i n c m p
+** (jws) simplified the code a bit in hopes of appeasing Purify
+**************************************************************************/
+int ficlStrincmp(char *cp1, char *cp2, ficlUnsigned count)
+{
+ int i = 0;
+
+ for (; 0 < count; ++cp1, ++cp2, --count)
+ {
+ i = tolower((unsigned char)*cp1) - tolower((unsigned char)*cp2);
+ if (i != 0)
+ return i;
+ else if (*cp1 == '\0')
+ return 0;
+ }
+ return 0;
+}
+
+/**************************************************************************
+ s k i p S p a c e
+** Given a string pointer, returns a pointer to the first non-space
+** char of the string, or to the NULL terminator if no such char found.
+** If the pointer reaches "end" first, stop there. Pass NULL to
+** suppress this behavior.
+**************************************************************************/
+char *ficlStringSkipSpace(char *cp, char *end)
+{
+ FICL_ASSERT(NULL, cp);
+
+ while ((cp != end) && isspace((unsigned char)*cp))
+ cp++;
+
+ return cp;
+}
+
+
+
+
+
+void ficlCompatibilityTextOutCallback(ficlCallback *callback, char *text, ficlCompatibilityOutputFunction outputFunction)
+{
+ char buffer[256];
+ char *bufferStop = buffer + sizeof(buffer) - 1;
+
+ if (text == NULL)
+ {
+ outputFunction(callback->vm, NULL, 0 /* false */);
+ return;
+ }
+
+ while (*text)
+ {
+ int newline = 0 /* false */;
+ char *trace = buffer;
+ while ((*text) && (trace < bufferStop))
+ {
+ switch (*text)
+ {
+ /* throw away \r */
+ case '\r':
+ text++;
+ continue;
+ case '\n':
+ text++;
+ newline = !0 /* true */;
+ break;
+ default:
+ *trace++ = *text++;
+ break;
+ }
+ }
+
+ *trace = 0;
+ (outputFunction)(callback->vm, buffer, newline);
+ }
+}
diff --git a/vm.c b/vm.c
index a36196df19a9..f3d9862fcf4a 100644
--- a/vm.c
+++ b/vm.c
@@ -3,14 +3,14 @@
** Forth Inspired Command Language - virtual machine methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: vm.c,v 1.12 2001-12-04 17:58:14-08 jsadler Exp jsadler $
+** $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $
*******************************************************************/
/*
-** This file implements the virtual machine of FICL. Each virtual
+** This file implements the virtual machine of Ficl. Each virtual
** machine retains the state of an interpreter. A virtual machine
** owns a pair of stacks for parameters and return addresses, as
** well as a pile of state variables and the two dedicated registers
-** of the interp.
+** of the interpreter.
*/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
@@ -18,9 +18,9 @@
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
-** I am interested in hearing from anyone who uses ficl. If you have
+** 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
+** if you would like to contribute to the Ficl release, please
** 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
@@ -54,53 +54,54 @@
#include <ctype.h>
#include "ficl.h"
-static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
+#if FICL_ROBUST >= 2
+#define FICL_VM_CHECK(vm) FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord)
+#else
+#define FICL_VM_CHECK(vm)
+#endif
/**************************************************************************
v m B r a n c h R e l a t i v e
**
**************************************************************************/
-void vmBranchRelative(FICL_VM *pVM, int offset)
+void ficlVmBranchRelative(ficlVm *vm, int offset)
{
- pVM->ip += offset;
+ vm->ip += offset;
return;
}
/**************************************************************************
v m C r e a t e
-** Creates a virtual machine either from scratch (if pVM is NULL on entry)
+** Creates a virtual machine either from scratch (if vm is NULL on entry)
** or by resizing and reinitializing an existing VM to the specified stack
** sizes.
**************************************************************************/
-FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
+ficlVm *ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack)
{
- if (pVM == NULL)
+ if (vm == NULL)
{
- pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
- assert (pVM);
- memset(pVM, 0, sizeof (FICL_VM));
+ vm = (ficlVm *)ficlMalloc(sizeof (ficlVm));
+ FICL_ASSERT(NULL, vm);
+ memset(vm, 0, sizeof (ficlVm));
}
- if (pVM->pStack)
- stackDelete(pVM->pStack);
- pVM->pStack = stackCreate(nPStack);
+ if (vm->dataStack)
+ ficlStackDestroy(vm->dataStack);
+ vm->dataStack = ficlStackCreate(vm, "data", nPStack);
- if (pVM->rStack)
- stackDelete(pVM->rStack);
- pVM->rStack = stackCreate(nRStack);
+ if (vm->returnStack)
+ ficlStackDestroy(vm->returnStack);
+ vm->returnStack = ficlStackCreate(vm, "return", nRStack);
#if FICL_WANT_FLOAT
- if (pVM->fStack)
- stackDelete(pVM->fStack);
- pVM->fStack = stackCreate(nPStack);
+ if (vm->floatStack)
+ ficlStackDestroy(vm->floatStack);
+ vm->floatStack = ficlStackCreate(vm, "float", nPStack);
#endif
- pVM->textOut = ficlTextOut;
-
- vmReset(pVM);
- return pVM;
+ ficlVmReset(vm);
+ return vm;
}
@@ -109,37 +110,69 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
** Free all memory allocated to the specified VM and its subordinate
** structures.
**************************************************************************/
-void vmDelete (FICL_VM *pVM)
+void ficlVmDestroy(ficlVm *vm)
{
- if (pVM)
+ if (vm)
{
- ficlFree(pVM->pStack);
- ficlFree(pVM->rStack);
+ ficlFree(vm->dataStack);
+ ficlFree(vm->returnStack);
#if FICL_WANT_FLOAT
- ficlFree(pVM->fStack);
+ ficlFree(vm->floatStack);
#endif
- ficlFree(pVM);
+ ficlFree(vm);
}
return;
}
+
+
/**************************************************************************
v m E x e c u t e
** Sets up the specified word to be run by the inner interpreter.
** Executes the word's code part immediately, but in the case of
-** colon definition, the definition itself needs the inner interp
+** colon definition, the definition itself needs the inner interpreter
** to complete. This does not happen until control reaches ficlExec
**************************************************************************/
-void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
+void ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
{
- pVM->runningWord = pWord;
- pWord->code(pVM);
+ ficlVmInnerLoop(vm, pWord);
return;
}
+
+static void ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip)
+ {
+ ficlIp destination;
+ switch ((ficlInstruction)(*ip))
+ {
+ case ficlInstructionBranchParenWithCheck:
+ *ip = (ficlWord *)ficlInstructionBranchParen;
+ goto RUNTIME_FIXUP;
+
+ case ficlInstructionBranch0ParenWithCheck:
+ *ip = (ficlWord *)ficlInstructionBranch0Paren;
+RUNTIME_FIXUP:
+ ip++;
+ destination = ip + *(int *)ip;
+ switch ((ficlInstruction)*destination)
+ {
+ case ficlInstructionBranchParenWithCheck:
+ /* preoptimize where we're jumping to */
+ ficlVmOptimizeJumpToJump(vm, destination);
+ case ficlInstructionBranchParen:
+ {
+ destination++;
+ destination += *(int *)destination;
+ *ip = (ficlWord *)(destination - ip);
+ break;
+ }
+ }
+ }
+ }
+
/**************************************************************************
v m I n n e r L o o p
** the mysterious inner interpreter...
@@ -149,131 +182,2177 @@ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
** until something does vmThrow. The catcher for this is expected to exist
** in the calling code.
** vmThrow gets you out of this loop with a longjmp()
-** Visual C++ 5 chokes on this loop in Release mode. Aargh.
**************************************************************************/
-#if INLINE_INNER_LOOP == 0
-void vmInnerLoop(FICL_VM *pVM)
+
+
+#if FICL_ROBUST <= 1
+ /* turn off stack checking for primitives */
+ #define _CHECK_STACK(stack, top, pop, push)
+#else
+
+#define _CHECK_STACK(stack, top, pop, push) \
+ ficlStackCheckNospill(stack, top, pop, push)
+
+FICL_PLATFORM_INLINE void ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells, int pushCells)
{
- M_INNER_LOOP(pVM);
+ /*
+ ** Why save and restore stack->top?
+ ** So the simple act of stack checking doesn't force a "register" spill,
+ ** which might mask bugs (places where we needed to spill but didn't).
+ ** --lch
+ */
+ ficlCell *oldTop = stack->top;
+ stack->top = top;
+ ficlStackCheck(stack, popCells, pushCells);
+ stack->top = oldTop;
}
-#endif
-#if 0
-/*
-** Recast inner loop that inlines tokens for control structures, arithmetic and stack operations,
-** as well as create does> : ; and various literals
-*/
-typedef enum
-{
- PATCH = 0,
- L0,
- L1,
- L2,
- LMINUS1,
- LMINUS2,
- DROP,
- SWAP,
- DUP,
- PICK,
- ROLL,
- FETCH,
- STORE,
- BRANCH,
- CBRANCH,
- LEAVE,
- TO_R,
- R_FROM,
- EXIT;
-} OPCODE;
-
-typedef CELL *IPTYPE;
-
-void vmInnerLoop(FICL_VM *pVM)
-{
- IPTYPE ip = pVM->ip;
- FICL_STACK *pStack = pVM->pStack;
- for (;;)
- {
- OPCODE o = (*ip++).i;
- CELL c;
- switch (o)
- {
- case L0:
- stackPushINT(pStack, 0);
- break;
- case L1:
- stackPushINT(pStack, 1);
- break;
- case L2:
- stackPushINT(pStack, 2);
- break;
- case LMINUS1:
- stackPushINT(pStack, -1);
- break;
- case LMINUS2:
- stackPushINT(pStack, -2);
- break;
- case DROP:
- stackDrop(pStack, 1);
- break;
- case SWAP:
- stackRoll(pStack, 1);
- break;
- case DUP:
- stackPick(pStack, 0);
- break;
- case PICK:
- c = *ip++;
- stackPick(pStack, c.i);
- break;
- case ROLL:
- c = *ip++;
- stackRoll(pStack, c.i);
- break;
- case EXIT:
- return;
- }
- }
+#endif /* FICL_ROBUST <= 1 */
- return;
-}
+#define CHECK_STACK(pop, push) _CHECK_STACK(vm->dataStack, dataTop, pop, push)
+#define CHECK_FLOAT_STACK(pop, push) _CHECK_STACK(vm->floatStack, floatTop, pop, push)
+#define CHECK_RETURN_STACK(pop, push) _CHECK_STACK(vm->returnStack, returnTop, pop, push)
+
+
+#if FICL_WANT_FLOAT
+ #define FLOAT_LOCAL_VARIABLE_SPILL \
+ vm->floatStack->top = floatTop;
+ #define FLOAT_LOCAL_VARIABLE_REFILL \
+ floatTop = vm->floatStack->top;
+#else
+ #define FLOAT_LOCAL_VARIABLE_SPILL
+ #define FLOAT_LOCAL_VARIABLE_REFILL
+#endif /* FICL_WANT_FLOAT */
+
+
+#if FICL_WANT_LOCALS
+ #define LOCALS_LOCAL_VARIABLE_SPILL \
+ vm->returnStack->frame = frame;
+ #define LOCALS_LOCAL_VARIABLE_REFILL \
+ frame = vm->returnStack->frame;
+#else
+ #define LOCALS_LOCAL_VARIABLE_SPILL
+ #define LOCALS_LOCAL_VARIABLE_REFILL
+#endif /* FICL_WANT_FLOAT */
+
+
+#define LOCAL_VARIABLE_SPILL \
+ vm->ip = (ficlIp)ip; \
+ vm->dataStack->top = dataTop; \
+ vm->returnStack->top = returnTop; \
+ FLOAT_LOCAL_VARIABLE_SPILL \
+ LOCALS_LOCAL_VARIABLE_SPILL
+
+#define LOCAL_VARIABLE_REFILL \
+ ip = (ficlInstruction *)vm->ip; \
+ dataTop = vm->dataStack->top; \
+ returnTop = vm->returnStack->top; \
+ FLOAT_LOCAL_VARIABLE_REFILL \
+ LOCALS_LOCAL_VARIABLE_REFILL
+
+
+void ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
+{
+ register ficlInstruction *ip;
+ register ficlCell *dataTop;
+ register ficlCell *returnTop;
+#if FICL_WANT_FLOAT
+ register ficlCell *floatTop;
+ ficlFloat f;
+#endif /* FICL_WANT_FLOAT */
+#if FICL_WANT_LOCALS
+ register ficlCell *frame;
+#endif /* FICL_WANT_LOCALS */
+ jmp_buf *oldExceptionHandler;
+ jmp_buf exceptionHandler;
+ int except;
+ int once;
+ int count;
+ ficlInstruction instruction;
+ ficlInteger i;
+ ficlUnsigned u;
+ ficlCell c;
+ ficlCountedString *s;
+ ficlCell *cell;
+ char *cp;
+
+ once = (fw != NULL);
+ if (once)
+ count = 1;
+
+ LOCAL_VARIABLE_REFILL;
+
+ oldExceptionHandler = vm->exceptionHandler;
+ vm->exceptionHandler = &exceptionHandler; /* This has to come before the setjmp! */
+ except = setjmp(exceptionHandler);
+
+ if (except)
+ {
+ LOCAL_VARIABLE_SPILL;
+ vm->exceptionHandler = oldExceptionHandler;
+ ficlVmThrow(vm, except);
+ }
+
+ for (;;)
+ {
+
+ if (once)
+ {
+ if (!count--)
+ break;
+ instruction = (ficlInstruction)((void *)fw);
+ }
+ else
+ {
+ instruction = *ip++;
+ fw = (ficlWord *)instruction;
+ }
+
+AGAIN:
+ switch (instruction)
+ {
+ case ficlInstructionInvalid:
+ {
+ ficlVmThrowError(vm, "Error: NULL instruction executed!");
+ return;
+ }
+
+ case ficlInstruction1:
+ case ficlInstruction2:
+ case ficlInstruction3:
+ case ficlInstruction4:
+ case ficlInstruction5:
+ case ficlInstruction6:
+ case ficlInstruction7:
+ case ficlInstruction8:
+ case ficlInstruction9:
+ case ficlInstruction10:
+ case ficlInstruction11:
+ case ficlInstruction12:
+ case ficlInstruction13:
+ case ficlInstruction14:
+ case ficlInstruction15:
+ case ficlInstruction16:
+ {
+ CHECK_STACK(0, 1);
+ (++dataTop)->i = instruction;
+ continue;
+ }
+
+ case ficlInstruction0:
+ case ficlInstructionNeg1:
+ case ficlInstructionNeg2:
+ case ficlInstructionNeg3:
+ case ficlInstructionNeg4:
+ case ficlInstructionNeg5:
+ case ficlInstructionNeg6:
+ case ficlInstructionNeg7:
+ case ficlInstructionNeg8:
+ case ficlInstructionNeg9:
+ case ficlInstructionNeg10:
+ case ficlInstructionNeg11:
+ case ficlInstructionNeg12:
+ case ficlInstructionNeg13:
+ case ficlInstructionNeg14:
+ case ficlInstructionNeg15:
+ case ficlInstructionNeg16:
+ {
+ CHECK_STACK(0, 1);
+ (++dataTop)->i = ficlInstruction0 - instruction;
+ continue;
+ }
+
+ /**************************************************************************
+ ** stringlit: Fetch the count from the dictionary, then push the address
+ ** and count on the stack. Finally, update ip to point to the first
+ ** aligned address after the string text.
+ **************************************************************************/
+ case ficlInstructionStringLiteralParen:
+ {
+ ficlUnsigned8 length;
+ CHECK_STACK(0, 2);
+
+ s = (ficlCountedString *)(ip);
+ length = s->length;
+ cp = s->text;
+ (++dataTop)->p = cp;
+ (++dataTop)->i = length;
+
+ cp += length + 1;
+ cp = ficlAlignPointer(cp);
+ ip = (void *)cp;
+ continue;
+ }
+
+ case ficlInstructionCStringLiteralParen:
+ {
+ CHECK_STACK(0, 1);
+
+ s = (ficlCountedString *)(ip);
+ cp = s->text + s->length + 1;
+ cp = ficlAlignPointer(cp);
+ ip = (void *)cp;
+ (++dataTop)->p = s;
+ continue;
+ }
+
+
+#if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
+ #if FICL_WANT_FLOAT
+ FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
+ *++floatTop = cell[1];
+ /* intentional fall-through */
+ FLOAT_PUSH_CELL_POINTER_MINIPROC:
+ *++floatTop = cell[0];
+ continue;
+
+ FLOAT_POP_CELL_POINTER_MINIPROC:
+ cell[0] = *floatTop--;
+ continue;
+ FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
+ cell[0] = *floatTop--;
+ cell[1] = *floatTop--;
+ continue;
+
+ #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
+ #define FLOAT_PUSH_CELL_POINTER(cp) cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
+ #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
+ #define FLOAT_POP_CELL_POINTER(cp) cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
+ #endif /* FICL_WANT_FLOAT */
+
+ /*
+ ** Think of these as little mini-procedures.
+ ** --lch
+ */
+ PUSH_CELL_POINTER_DOUBLE_MINIPROC:
+ *++dataTop = cell[1];
+ /* intentional fall-through */
+ PUSH_CELL_POINTER_MINIPROC:
+ *++dataTop = cell[0];
+ continue;
+
+ POP_CELL_POINTER_MINIPROC:
+ cell[0] = *dataTop--;
+ continue;
+ POP_CELL_POINTER_DOUBLE_MINIPROC:
+ cell[0] = *dataTop--;
+ cell[1] = *dataTop--;
+ continue;
+
+ #define PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
+ #define PUSH_CELL_POINTER(cp) cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
+ #define POP_CELL_POINTER_DOUBLE(cp) cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
+ #define POP_CELL_POINTER(cp) cell = (cp); goto POP_CELL_POINTER_MINIPROC
+
+ BRANCH_MINIPROC:
+ ip += *(int *)ip;
+ continue;
+
+ #define BRANCH() goto BRANCH_MINIPROC
+
+ EXIT_FUNCTION_MINIPROC:
+ ip = (ficlInstruction *)((returnTop--)->p);
+ continue;
+
+ #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC
+
+#else /* FICL_WANT_SIZE */
+
+ #if FICL_WANT_FLOAT
+ #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
+ #define FLOAT_PUSH_CELL_POINTER(cp) cell = (cp); *++floatTop = *cell; continue
+ #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
+ #define FLOAT_POP_CELL_POINTER(cp) cell = (cp); *cell = *floatTop--; continue
+ #endif /* FICL_WANT_FLOAT */
+
+ #define PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
+ #define PUSH_CELL_POINTER(cp) cell = (cp); *++dataTop = *cell; continue
+ #define POP_CELL_POINTER_DOUBLE(cp) cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
+ #define POP_CELL_POINTER(cp) cell = (cp); *cell = *dataTop--; continue
+
+ #define BRANCH() ip += *(ficlInteger *)ip; continue
+ #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue
+
+#endif /* FICL_WANT_SIZE */
+
+
+ /**************************************************************************
+ ** This is the runtime for (literal). It assumes that it is part of a colon
+ ** definition, and that the next ficlCell contains a value to be pushed on the
+ ** parameter stack at runtime. This code is compiled by "literal".
+ **************************************************************************/
+
+ case ficlInstructionLiteralParen:
+ {
+ CHECK_STACK(0, 1);
+ (++dataTop)->i = *ip++;
+ continue;
+ }
+
+ case ficlInstruction2LiteralParen:
+ {
+ CHECK_STACK(0, 2);
+ (++dataTop)->i = ip[1];
+ (++dataTop)->i = ip[0];
+ ip += 2;
+ continue;
+ }
+
+
+#if FICL_WANT_LOCALS
+ /**************************************************************************
+ ** Link a frame on the return stack, reserving nCells of space for
+ ** locals - the value of nCells is the next ficlCell in the instruction
+ ** stream.
+ ** 1) Push frame onto returnTop
+ ** 2) frame = returnTop
+ ** 3) returnTop += nCells
+ **************************************************************************/
+ case ficlInstructionLinkParen:
+ {
+ ficlInteger nCells = *ip++;
+ (++returnTop)->p = frame;
+ frame = returnTop + 1;
+ returnTop += nCells;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** Unink a stack frame previously created by stackLink
+ ** 1) dataTop = frame
+ ** 2) frame = pop()
+ *******************************************************************/
+ case ficlInstructionUnlinkParen:
+ {
+ returnTop = frame - 1;
+ frame = (returnTop--)->p;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** Immediate - cfa of a local while compiling - when executed, compiles
+ ** code to fetch the value of a local given the local's index in the
+ ** word's pfa
+ **************************************************************************/
+#if FICL_WANT_FLOAT
+ case ficlInstructionGetF2LocalParen:
+ FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionGetFLocalParen:
+ FLOAT_PUSH_CELL_POINTER(frame + *ip++);
+
+ case ficlInstructionToF2LocalParen:
+ FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionToFLocalParen:
+ FLOAT_POP_CELL_POINTER(frame + *ip++);
+#endif /* FICL_WANT_FLOAT */
+
+ case ficlInstructionGet2LocalParen:
+ PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionGetLocalParen:
+ PUSH_CELL_POINTER(frame + *ip++);
+
+ /**************************************************************************
+ ** Immediate - cfa of a local while compiling - when executed, compiles
+ ** code to store the value of a local given the local's index in the
+ ** word's pfa
+ **************************************************************************/
+
+ case ficlInstructionTo2LocalParen:
+ POP_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionToLocalParen:
+ POP_CELL_POINTER(frame + *ip++);
+
+ /*
+ ** Silly little minor optimizations.
+ ** --lch
+ */
+ case ficlInstructionGetLocal0:
+ PUSH_CELL_POINTER(frame);
+
+ case ficlInstructionGetLocal1:
+ PUSH_CELL_POINTER(frame + 1);
+
+ case ficlInstructionGet2Local0:
+ PUSH_CELL_POINTER_DOUBLE(frame);
+
+ case ficlInstructionToLocal0:
+ POP_CELL_POINTER(frame);
+
+ case ficlInstructionToLocal1:
+ POP_CELL_POINTER(frame + 1);
+
+ case ficlInstructionTo2Local0:
+ POP_CELL_POINTER_DOUBLE(frame);
+
+#endif /* FICL_WANT_LOCALS */
+
+ case ficlInstructionPlus:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i += i;
+ continue;
+ }
+
+ case ficlInstructionMinus:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i -= i;
+ continue;
+ }
+
+ case ficlInstruction1Plus:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i++;
+ continue;
+ }
+
+ case ficlInstruction1Minus:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i--;
+ continue;
+ }
+
+ case ficlInstruction2Plus:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i += 2;
+ continue;
+ }
+
+ case ficlInstruction2Minus:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i -= 2;
+ continue;
+ }
+
+ case ficlInstructionDup:
+ {
+ ficlInteger i = dataTop->i;
+ CHECK_STACK(0, 1);
+ (++dataTop)->i = i;
+ continue;
+ }
+
+ case ficlInstructionQuestionDup:
+ {
+ CHECK_STACK(1, 2);
+
+ if (dataTop->i != 0)
+ {
+ dataTop[1] = dataTop[0];
+ dataTop++;
+ }
+
+ continue;
+ }
+
+ case ficlInstructionSwap:
+ {
+ ficlCell swap;
+ CHECK_STACK(2, 2);
+ swap = dataTop[0];
+ dataTop[0] = dataTop[-1];
+ dataTop[-1] = swap;
+ continue;
+ }
+
+ case ficlInstructionDrop:
+ {
+ CHECK_STACK(1, 0);
+ dataTop--;
+ continue;
+ }
+
+
+ case ficlInstruction2Drop:
+ {
+ CHECK_STACK(2, 0);
+ dataTop -= 2;
+ continue;
+ }
+
+
+ case ficlInstruction2Dup:
+ {
+ CHECK_STACK(2, 4);
+ dataTop[1] = dataTop[-1];
+ dataTop[2] = *dataTop;
+ dataTop += 2;
+ continue;
+ }
+
+
+ case ficlInstructionOver:
+ {
+ CHECK_STACK(2, 3);
+ dataTop[1] = dataTop[-1];
+ dataTop++;
+ continue;
+ }
+
+ case ficlInstruction2Over:
+ {
+ CHECK_STACK(4, 6);
+ dataTop[1] = dataTop[-3];
+ dataTop[2] = dataTop[-2];
+ dataTop += 2;
+ continue;
+ }
+
+
+ case ficlInstructionPick:
+ {
+ CHECK_STACK(1, 0);
+ i = dataTop->i;
+ if (i < 0)
+ continue;
+ CHECK_STACK(i + 1, i + 2);
+ *dataTop = dataTop[-i];
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Do stack rot.
+ ** rot ( 1 2 3 -- 2 3 1 )
+ *******************************************************************/
+ case ficlInstructionRot:
+ {
+ i = 2;
+ goto ROLL;
+ }
+
+ /*******************************************************************
+ ** Do stack roll.
+ ** roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionRoll:
+ {
+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+ROLL:
+ CHECK_STACK(i+1, i+2);
+ c = dataTop[-i];
+ memmove(dataTop - i, dataTop - (i - 1), i * sizeof(ficlCell));
+ *dataTop = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do stack -rot.
+ ** -rot ( 1 2 3 -- 3 1 2 )
+ *******************************************************************/
+ case ficlInstructionMinusRot:
+ {
+ i = 2;
+ goto MINUSROLL;
+ }
+
+
+ /*******************************************************************
+ ** Do stack -roll.
+ ** -roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionMinusRoll:
+ {
+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+MINUSROLL:
+ CHECK_STACK(i+1, i+2);
+ c = *dataTop;
+ memmove(dataTop - (i - 1), dataTop - i, i * sizeof(ficlCell));
+ dataTop[-i] = c;
+
+ continue;
+ }
+
+
+
+ /*******************************************************************
+ ** Do stack 2swap
+ ** 2swap ( 1 2 3 4 -- 3 4 1 2 )
+ *******************************************************************/
+ case ficlInstruction2Swap:
+ {
+ ficlCell c2;
+ CHECK_STACK(4, 4);
+
+ c = *dataTop;
+ c2 = dataTop[-1];
+
+ *dataTop = dataTop[-2];
+ dataTop[-1] = dataTop[-3];
+
+ dataTop[-2] = c;
+ dataTop[-3] = c2;
+ continue;
+ }
+
+
+ case ficlInstructionPlusStore:
+ {
+ ficlCell *cell;
+ CHECK_STACK(2, 0);
+ cell = (ficlCell *)(dataTop--)->p;
+ cell->i += (dataTop--)->i;
+ continue;
+ }
+
+
+ case ficlInstructionQuadFetch:
+ {
+ ficlUnsigned32 *integer32;
+ CHECK_STACK(1, 1);
+ integer32 = (ficlUnsigned32 *)dataTop->i;
+ dataTop->u = (ficlUnsigned)*integer32;
+ continue;
+ }
+
+ case ficlInstructionQuadStore:
+ {
+ ficlUnsigned32 *integer32;
+ CHECK_STACK(2, 0);
+ integer32 = (ficlUnsigned32 *)(dataTop--)->p;
+ *integer32 = (ficlUnsigned32)((dataTop--)->u);
+ continue;
+ }
+
+ case ficlInstructionWFetch:
+ {
+ ficlUnsigned16 *integer16;
+ CHECK_STACK(1, 1);
+ integer16 = (ficlUnsigned16 *)dataTop->p;
+ dataTop->u = ((ficlUnsigned)*integer16);
+ continue;
+ }
+
+ case ficlInstructionWStore:
+ {
+ ficlUnsigned16 *integer16;
+ CHECK_STACK(2, 0);
+ integer16 = (ficlUnsigned16 *)(dataTop--)->p;
+ *integer16 = (ficlUnsigned16)((dataTop--)->u);
+ continue;
+ }
+
+ case ficlInstructionCFetch:
+ {
+ ficlUnsigned8 *integer8;
+ CHECK_STACK(1, 1);
+ integer8 = (ficlUnsigned8 *)dataTop->p;
+ dataTop->u = ((ficlUnsigned)*integer8);
+ continue;
+ }
+
+ case ficlInstructionCStore:
+ {
+ ficlUnsigned8 *integer8;
+ CHECK_STACK(2, 0);
+ integer8 = (ficlUnsigned8 *)(dataTop--)->p;
+ *integer8 = (ficlUnsigned8)((dataTop--)->u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ l o g i c a n d c o m p a r i s o n s
+ **
+ **************************************************************************/
+
+ case ficlInstruction0Equals:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i == 0);
+ continue;
+ }
+
+ case ficlInstruction0Less:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i < 0);
+ continue;
+ }
+
+ case ficlInstruction0Greater:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i > 0);
+ continue;
+ }
+
+ case ficlInstructionEquals:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = FICL_BOOL(dataTop->i == i);
+ continue;
+ }
+
+ case ficlInstructionLess:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = FICL_BOOL(dataTop->i < i);
+ continue;
+ }
+
+ case ficlInstructionULess:
+ {
+ CHECK_STACK(2, 1);
+ u = (dataTop--)->u;
+ dataTop->i = FICL_BOOL(dataTop->u < u);
+ continue;
+ }
+
+ case ficlInstructionAnd:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i & i;
+ continue;
+ }
+
+ case ficlInstructionOr:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i | i;
+ continue;
+ }
+
+ case ficlInstructionXor:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i ^ i;
+ continue;
+ }
+
+ case ficlInstructionInvert:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i = ~dataTop->i;
+ continue;
+ }
+
+ /**************************************************************************
+ r e t u r n s t a c k
+ **
+ **************************************************************************/
+ case ficlInstructionToRStack:
+ {
+ CHECK_STACK(1, 0);
+ CHECK_RETURN_STACK(0, 1);
+ *++returnTop = *dataTop--;
+ continue;
+ }
+
+ case ficlInstructionFromRStack:
+ {
+ CHECK_STACK(0, 1);
+ CHECK_RETURN_STACK(1, 0);
+ *++dataTop = *returnTop--;
+ continue;
+ }
+
+ case ficlInstructionFetchRStack:
+ {
+ CHECK_STACK(0, 1);
+ CHECK_RETURN_STACK(1, 1);
+ *++dataTop = *returnTop;
+ continue;
+ }
+
+ case ficlInstruction2ToR:
+ {
+ CHECK_STACK(2, 0);
+ CHECK_RETURN_STACK(0, 2);
+ *++returnTop = dataTop[-1];
+ *++returnTop = dataTop[0];
+ dataTop -= 2;
+ continue;
+ }
+
+ case ficlInstruction2RFrom:
+ {
+ CHECK_STACK(0, 2);
+ CHECK_RETURN_STACK(2, 0);
+ *++dataTop = returnTop[-1];
+ *++dataTop = returnTop[0];
+ returnTop -= 2;
+ continue;
+ }
+
+ case ficlInstruction2RFetch:
+ {
+ CHECK_STACK(0, 2);
+ CHECK_RETURN_STACK(2, 2);
+ *++dataTop = returnTop[-1];
+ *++dataTop = returnTop[0];
+ continue;
+ }
+
+
+ /**************************************************************************
+ f i l l
+ ** CORE ( c-addr u char -- )
+ ** If u is greater than zero, store char in each of u consecutive
+ ** characters of memory beginning at c-addr.
+ **************************************************************************/
+ case ficlInstructionFill:
+ {
+ char c;
+ char *memory;
+ CHECK_STACK(3, 0);
+ c = (char)(dataTop--)->i;
+ u = (dataTop--)->u;
+ memory = (char *)(dataTop--)->p;
+
+ /* memset() is faster than the previous hand-rolled solution. --lch */
+ memset(memory, c, u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ l s h i f t
+ ** l-shift CORE ( x1 u -- x2 )
+ ** Perform a logical left shift of u bit-places on x1, giving x2.
+ ** Put zeroes into the least significant bits vacated by the shift.
+ ** An ambiguous condition exists if u is greater than or equal to the
+ ** number of bits in a ficlCell.
+ **
+ ** r-shift CORE ( x1 u -- x2 )
+ ** Perform a logical right shift of u bit-places on x1, giving x2.
+ ** Put zeroes into the most significant bits vacated by the shift. An
+ ** ambiguous condition exists if u is greater than or equal to the
+ ** number of bits in a ficlCell.
+ **************************************************************************/
+ case ficlInstructionLShift:
+ {
+ ficlUnsigned nBits;
+ ficlUnsigned x1;
+ CHECK_STACK(2, 1);
+
+ nBits = (dataTop--)->u;
+ x1 = dataTop->u;
+ dataTop->u = x1 << nBits;
+ continue;
+ }
+
+
+ case ficlInstructionRShift:
+ {
+ ficlUnsigned nBits;
+ ficlUnsigned x1;
+ CHECK_STACK(2, 1);
+
+ nBits = (dataTop--)->u;
+ x1 = dataTop->u;
+ dataTop->u = x1 >> nBits;
+ continue;
+ }
+
+
+ /**************************************************************************
+ m a x & m i n
+ **
+ **************************************************************************/
+ case ficlInstructionMax:
+ {
+ ficlInteger n2;
+ ficlInteger n1;
+ CHECK_STACK(2, 1);
+
+ n2 = (dataTop--)->i;
+ n1 = dataTop->i;
+
+ dataTop->i = ((n1 > n2) ? n1 : n2);
+ continue;
+ }
+
+ case ficlInstructionMin:
+ {
+ ficlInteger n2;
+ ficlInteger n1;
+ CHECK_STACK(2, 1);
+
+ n2 = (dataTop--)->i;
+ n1 = dataTop->i;
+
+ dataTop->i = ((n1 < n2) ? n1 : n2);
+ continue;
+ }
+
+
+ /**************************************************************************
+ m o v e
+ ** CORE ( addr1 addr2 u -- )
+ ** If u is greater than zero, copy the contents of u consecutive address
+ ** units at addr1 to the u consecutive address units at addr2. After MOVE
+ ** completes, the u consecutive address units at addr2 contain exactly
+ ** what the u consecutive address units at addr1 contained before the move.
+ ** NOTE! This implementation assumes that a char is the same size as
+ ** an address unit.
+ **************************************************************************/
+ case ficlInstructionMove:
+ {
+ ficlUnsigned u;
+ char *addr2;
+ char *addr1;
+ CHECK_STACK(3, 0);
+
+ u = (dataTop--)->u;
+ addr2 = (dataTop--)->p;
+ addr1 = (dataTop--)->p;
+
+ if (u == 0)
+ continue;
+ /*
+ ** Do the copy carefully, so as to be
+ ** correct even if the two ranges overlap
+ */
+ /* Which ANSI C's memmove() does for you! Yay! --lch */
+ memmove(addr2, addr1, u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ s t o d
+ ** s-to-d CORE ( n -- d )
+ ** Convert the number n to the double-ficlCell number d with the same
+ ** numerical value.
+ **************************************************************************/
+ case ficlInstructionSToD:
+ {
+ ficlInteger s;
+ CHECK_STACK(1, 2);
+
+ s = dataTop->i;
+
+ /* sign extend to 64 bits.. */
+ (++dataTop)->i = (s < 0) ? -1 : 0;
+ continue;
+ }
+
+
+ /**************************************************************************
+ c o m p a r e
+ ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
+ ** Compare the string specified by c-addr1 u1 to the string specified by
+ ** c-addr2 u2. The strings are compared, beginning at the given addresses,
+ ** character by character, up to the length of the shorter string or until a
+ ** difference is found. If the two strings are identical, n is zero. If the two
+ ** strings are identical up to the length of the shorter string, n is minus-one
+ ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
+ ** identical up to the length of the shorter string, n is minus-one (-1) if the
+ ** first non-matching character in the string specified by c-addr1 u1 has a
+ ** lesser numeric value than the corresponding character in the string specified
+ ** by c-addr2 u2 and one (1) otherwise.
+ **************************************************************************/
+ case ficlInstructionCompare:
+ {
+ i = FICL_FALSE;
+ goto COMPARE;
+ }
+
+
+ case ficlInstructionCompareInsensitive:
+ {
+ i = FICL_TRUE;
+ goto COMPARE;
+ }
+
+COMPARE:
+ {
+ char *cp1, *cp2;
+ ficlUnsigned u1, u2, uMin;
+ int n = 0;
+
+ CHECK_STACK(4, 1);
+ u2 = (dataTop--)->u;
+ cp2 = (char *)(dataTop--)->p;
+ u1 = (dataTop--)->u;
+ cp1 = (char *)(dataTop--)->p;
+
+ uMin = (u1 < u2)? u1 : u2;
+ for ( ; (uMin > 0) && (n == 0); uMin--)
+ {
+ int c1 = (unsigned char)*cp1++;
+ int c2 = (unsigned char)*cp2++;
+ if (i)
+ {
+ c1 = tolower(c1);
+ c2 = tolower(c2);
+ }
+ n = (c1 - c2);
+ }
+
+ if (n == 0)
+ n = (int)(u1 - u2);
+
+ if (n < 0)
+ n = -1;
+ else if (n > 0)
+ n = 1;
+
+ (++dataTop)->i = n;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** r a n d o m
+ ** Ficl-specific
+ **************************************************************************/
+ case ficlInstructionRandom:
+ {
+ (++dataTop)->i = rand();
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** s e e d - r a n d o m
+ ** Ficl-specific
+ **************************************************************************/
+ case ficlInstructionSeedRandom:
+ {
+ srand((dataTop--)->i);
+ continue;
+ }
+
+
+
+ case ficlInstructionGreaterThan:
+ {
+ ficlInteger x, y;
+ CHECK_STACK(2, 1);
+ y = (dataTop--)->i;
+ x = dataTop->i;
+ dataTop->i = FICL_BOOL(x > y);
+ continue;
+ }
+
+ /**************************************************************************
+ ** This function simply pops the previous instruction
+ ** pointer and returns to the "next" loop. Used for exiting from within
+ ** a definition. Note that exitParen is identical to semiParen - they
+ ** are in two different functions so that "see" can correctly identify
+ ** the end of a colon definition, even if it uses "exit".
+ **************************************************************************/
+ case ficlInstructionExitParen:
+ case ficlInstructionSemiParen:
+ EXIT_FUNCTION();
+
+ /**************************************************************************
+ ** The first time we run "(branch)", perform a "peephole optimization" to
+ ** see if we're jumping to another unconditional jump. If so, just jump
+ ** directly there.
+ **************************************************************************/
+ case ficlInstructionBranchParenWithCheck:
+ {
+ LOCAL_VARIABLE_SPILL;
+ ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
+ LOCAL_VARIABLE_REFILL;
+ goto BRANCH_PAREN;
+ }
+
+ /**************************************************************************
+ ** Same deal with branch0.
+ **************************************************************************/
+ case ficlInstructionBranch0ParenWithCheck:
+ {
+ LOCAL_VARIABLE_SPILL;
+ ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
+ LOCAL_VARIABLE_REFILL;
+ /* intentional fall-through */
+ }
+
+ /**************************************************************************
+ ** Runtime code for "(branch0)"; pop a flag from the stack,
+ ** branch if 0. fall through otherwise. The heart of "if" and "until".
+ **************************************************************************/
+ case ficlInstructionBranch0Paren:
+ {
+ CHECK_STACK(1, 0);
+
+ if ((dataTop--)->i)
+ {
+ /* don't branch, but skip over branch relative address */
+ ip += 1;
+ continue;
+ }
+ /* otherwise, take branch (to else/endif/begin) */
+ /* intentional fall-through! */
+ }
+
+ /**************************************************************************
+ ** Runtime for "(branch)" -- expects a literal offset in the next
+ ** compilation address, and branches to that location.
+ **************************************************************************/
+ case ficlInstructionBranchParen:
+ {
+BRANCH_PAREN:
+ BRANCH();
+ }
+
+ case ficlInstructionOfParen:
+ {
+ ficlUnsigned a, b;
+
+ CHECK_STACK(2, 1);
+
+ a = (dataTop--)->u;
+ b = dataTop->u;
+
+ if (a == b)
+ {
+ /* fall through */
+ ip++;
+ /* remove CASE argument */
+ dataTop--;
+ }
+ else
+ {
+ /* take branch to next of or endcase */
+ BRANCH();
+ }
+
+ continue;
+ }
+
+ case ficlInstructionDoParen:
+ {
+ ficlCell index, limit;
+
+ CHECK_STACK(2, 0);
+
+ index = *dataTop--;
+ limit = *dataTop--;
+
+ /* copy "leave" target addr to stack */
+ (++returnTop)->i = *(ip++);
+ *++returnTop = limit;
+ *++returnTop = index;
+
+ continue;
+ }
+
+ case ficlInstructionQDoParen:
+ {
+ ficlCell index, limit, leave;
+
+ CHECK_STACK(2, 0);
+
+ index = *dataTop--;
+ limit = *dataTop--;
+
+ leave.i = *ip;
+
+ if (limit.u == index.u)
+ {
+ ip = leave.p;
+ }
+ else
+ {
+ ip++;
+ *++returnTop = leave;
+ *++returnTop = limit;
+ *++returnTop = index;
+ }
+
+ continue;
+ }
+
+ case ficlInstructionLoopParen:
+ case ficlInstructionPlusLoopParen:
+ {
+ ficlInteger index;
+ ficlInteger limit;
+ int direction = 0;
+
+ index = returnTop->i;
+ limit = returnTop[-1].i;
+
+ if (instruction == ficlInstructionLoopParen)
+ index++;
+ else
+ {
+ ficlInteger increment;
+ CHECK_STACK(1, 0);
+ increment = (dataTop--)->i;
+ index += increment;
+ direction = (increment < 0);
+ }
+
+ if (direction ^ (index >= limit))
+ {
+ returnTop -= 3; /* nuke the loop indices & "leave" addr */
+ ip++; /* fall through the loop */
+ }
+ else
+ { /* update index, branch to loop head */
+ returnTop->i = index;
+ BRANCH();
+ }
+
+ continue;
+ }
+
+
+ /*
+ ** Runtime code to break out of a do..loop construct
+ ** Drop the loop control variables; the branch address
+ ** past "loop" is next on the return stack.
+ */
+ case ficlInstructionLeave:
+ {
+ /* almost unloop */
+ returnTop -= 2;
+ /* exit */
+ EXIT_FUNCTION();
+ }
+
+
+ case ficlInstructionUnloop:
+ {
+ returnTop -= 3;
+ continue;
+ }
+
+ case ficlInstructionI:
+ {
+ *++dataTop = *returnTop;
+ continue;
+ }
+
+
+ case ficlInstructionJ:
+ {
+ *++dataTop = returnTop[-3];
+ continue;
+ }
+
+
+ case ficlInstructionK:
+ {
+ *++dataTop = returnTop[-6];
+ continue;
+ }
+
+
+ case ficlInstructionDoesParen:
+ {
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ dictionary->smudge->code = (ficlPrimitive)ficlInstructionDoDoes;
+ dictionary->smudge->param[0].p = ip;
+ ip = (ficlInstruction *)((returnTop--)->p);
+ continue;
+ }
+
+ case ficlInstructionDoDoes:
+ {
+ ficlCell *cell;
+ ficlIp tempIP;
+
+ CHECK_STACK(0, 1);
+
+ cell = fw->param;
+ tempIP = (ficlIp)((*cell).p);
+ (++dataTop)->p = (cell + 1);
+ (++returnTop)->p = (void *)ip;
+ ip = (ficlInstruction *)tempIP;
+ continue;
+ }
+
+#if FICL_WANT_FLOAT
+ case ficlInstructionF2Fetch:
+ CHECK_FLOAT_STACK(0, 2);
+ CHECK_STACK(1, 0);
+ FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ case ficlInstructionFFetch:
+ CHECK_FLOAT_STACK(0, 1);
+ CHECK_STACK(1, 0);
+ FLOAT_PUSH_CELL_POINTER((dataTop--)->p);
+
+ case ficlInstructionF2Store:
+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(1, 0);
+ FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ case ficlInstructionFStore:
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(1, 0);
+ FLOAT_POP_CELL_POINTER((dataTop--)->p);
+#endif /* FICL_WANT_FLOAT */
+
+ /*
+ ** two-fetch CORE ( a-addr -- x1 x2 )
+ **
+ ** Fetch the ficlCell pair x1 x2 stored at a-addr. x2 is stored at a-addr
+ ** and x1 at the next consecutive ficlCell. It is equivalent to the
+ ** sequence DUP ficlCell+ @ SWAP @ .
+ */
+ case ficlInstruction2Fetch:
+ CHECK_STACK(1, 2);
+ PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ /*
+ ** fetch CORE ( a-addr -- x )
+ **
+ ** x is the value stored at a-addr.
+ */
+ case ficlInstructionFetch:
+ CHECK_STACK(1, 1);
+ PUSH_CELL_POINTER((dataTop--)->p);
+
+ /*
+ ** two-store CORE ( x1 x2 a-addr -- )
+ ** Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
+ ** next consecutive ficlCell. It is equivalent to the sequence
+ ** SWAP OVER ! ficlCell+ ! .
+ */
+ case ficlInstruction2Store:
+ CHECK_STACK(3, 0);
+ POP_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ /*
+ ** store CORE ( x a-addr -- )
+ ** Store x at a-addr.
+ */
+ case ficlInstructionStore:
+ CHECK_STACK(2, 0);
+ POP_CELL_POINTER((dataTop--)->p);
+
+ case ficlInstructionComma:
+ {
+ ficlDictionary *dictionary;
+ CHECK_STACK(1, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryAppendCell(dictionary, *dataTop--);
+ continue;
+ }
+
+ case ficlInstructionCComma:
+ {
+ ficlDictionary *dictionary;
+ char c;
+ CHECK_STACK(1, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ c = (char)(dataTop--)->i;
+ ficlDictionaryAppendCharacter(dictionary, c);
+ continue;
+ }
+
+ case ficlInstructionCells:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i *= sizeof(ficlCell);
+ continue;
+ }
+
+ case ficlInstructionCellPlus:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i += sizeof(ficlCell);
+ continue;
+ }
+
+ case ficlInstructionStar:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i *= i;
+ continue;
+ }
+
+ case ficlInstructionNegate:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i = - dataTop->i;
+ continue;
+ }
+
+ case ficlInstructionSlash:
+ {
+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i /= i;
+ continue;
+ }
+
+ /*
+ ** slash-mod CORE ( n1 n2 -- n3 n4 )
+ ** Divide n1 by n2, giving the single-ficlCell remainder n3 and the single-ficlCell
+ ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
+ ** differ in sign, the implementation-defined result returned will be the
+ ** same as that returned by either the phrase
+ ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
+ ** NOTE: Ficl complies with the second phrase (symmetric division)
+ */
+ case ficlInstructionSlashMod:
+ {
+ ficl2Integer n1;
+ ficlInteger n2;
+ ficl2IntegerQR qr;
+
+ CHECK_STACK(2, 2);
+ n2 = dataTop[0].i;
+ FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1);
+
+ qr = ficl2IntegerDivideSymmetric(n1, n2);
+ dataTop[-1].i = qr.remainder;
+ dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
+ continue;
+ }
+
+
+ case ficlInstruction2Star:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i <<= 1;
+ continue;
+ }
+
+ case ficlInstruction2Slash:
+ {
+ CHECK_STACK(1, 1);
+ dataTop->i >>= 1;
+ continue;
+ }
+
+ case ficlInstructionStarSlash:
+ {
+ ficlInteger x, y, z;
+ ficl2Integer prod;
+ CHECK_STACK(3, 1);
+
+ z = (dataTop--)->i;
+ y = (dataTop--)->i;
+ x = dataTop->i;
+
+ prod = ficl2IntegerMultiply(x,y);
+ dataTop->i = FICL_2UNSIGNED_GET_LOW(ficl2IntegerDivideSymmetric(prod, z).quotient);
+ continue;
+ }
+
+
+ case ficlInstructionStarSlashMod:
+ {
+ ficlInteger x, y, z;
+ ficl2Integer prod;
+ ficl2IntegerQR qr;
+
+ CHECK_STACK(3, 2);
+
+ z = (dataTop--)->i;
+ y = dataTop[0].i;
+ x = dataTop[-1].i;
+
+ prod = ficl2IntegerMultiply(x,y);
+ qr = ficl2IntegerDivideSymmetric(prod, z);
+
+ dataTop[-1].i = qr.remainder;
+ dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
+ continue;
+ }
+
+
+#if FICL_WANT_FLOAT
+
+ case ficlInstructionF0:
+ {
+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = 0.0f;
+ continue;
+ }
+
+
+ case ficlInstructionF1:
+ {
+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = 1.0f;
+ continue;
+ }
+
+
+ case ficlInstructionFNeg1:
+ {
+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = -1.0f;
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Floating point literal execution word.
+ *******************************************************************/
+ case ficlInstructionFLiteralParen:
+ {
+ CHECK_FLOAT_STACK(0, 1);
+
+ /* Yes, I'm using ->i here, but it's really a float. --lch */
+ (++floatTop)->i = *ip++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float addition r1 + r2.
+ ** f+ ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFPlus:
+ {
+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f += f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float subtraction r1 - r2.
+ ** f- ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFMinus:
+ {
+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f -= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float multiplication r1 * r2.
+ ** f* ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFStar:
+ {
+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f *= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float negation.
+ ** fnegate ( r -- r )
+ *******************************************************************/
+ case ficlInstructionFNegate:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+
+ floatTop->f = -(floatTop->f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float division r1 / r2.
+ ** f/ ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFSlash:
+ {
+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f /= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float + integer r + n.
+ ** f+i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFPlusI:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f += f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float - integer r - n.
+ ** f-i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFMinusI:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f -= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float * integer r * n.
+ ** f*i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFStarI:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f *= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float / integer r / n.
+ ** f/i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFSlashI:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f /= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer - float n - r.
+ ** i-f ( n r -- r )
+ *******************************************************************/
+ case ficlInstructionIMinusF:
+ {
+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f = f - floatTop->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer / float n / r.
+ ** i/f ( n r -- r )
+ *******************************************************************/
+ case ficlInstructionISlashF:
+ {
+ CHECK_FLOAT_STACK(1,1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f = f / floatTop->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer to float conversion.
+ ** int>float ( n -- r )
+ *******************************************************************/
+ case ficlInstructionIntToFloat:
+ {
+ CHECK_STACK(1, 0);
+ CHECK_FLOAT_STACK(0, 1);
+
+ (++floatTop)->f = (ficlFloat)((dataTop--)->i);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float to integer conversion.
+ ** float>int ( r -- n )
+ *******************************************************************/
+ case ficlInstructionFloatToInt:
+ {
+ CHECK_STACK(0, 1);
+ CHECK_FLOAT_STACK(1, 0);
+
+ (++dataTop)->i = (ficlInteger)((floatTop--)->f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Add a floating point number to contents of a variable.
+ ** f+! ( r n -- )
+ *******************************************************************/
+ case ficlInstructionFPlusStore:
+ {
+ ficlCell *cell;
+
+ CHECK_STACK(1, 0);
+ CHECK_FLOAT_STACK(1, 0);
+
+ cell = (ficlCell *)(dataTop--)->p;
+ cell->f += (floatTop--)->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack drop.
+ ** fdrop ( r -- )
+ *******************************************************************/
+ case ficlInstructionFDrop:
+ {
+ CHECK_FLOAT_STACK(1, 0);
+ floatTop--;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack ?dup.
+ ** f?dup ( r -- r )
+ *******************************************************************/
+ case ficlInstructionFQuestionDup:
+ {
+ CHECK_FLOAT_STACK(1, 2);
+
+ if (floatTop->f != 0)
+ goto FDUP;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack dup.
+ ** fdup ( r -- r r )
+ *******************************************************************/
+ case ficlInstructionFDup:
+ {
+ CHECK_FLOAT_STACK(1, 2);
+
+FDUP:
+ floatTop[1] = floatTop[0];
+ floatTop++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack swap.
+ ** fswap ( r1 r2 -- r2 r1 )
+ *******************************************************************/
+ case ficlInstructionFSwap:
+ {
+ CHECK_FLOAT_STACK(2, 2);
+
+ c = floatTop[0];
+ floatTop[0] = floatTop[-1];
+ floatTop[-1] = c;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2drop.
+ ** f2drop ( r r -- )
+ *******************************************************************/
+ case ficlInstructionF2Drop:
+ {
+ CHECK_FLOAT_STACK(2, 0);
+
+ floatTop -= 2;
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Do float stack 2dup.
+ ** f2dup ( r1 r2 -- r1 r2 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Dup:
+ {
+ CHECK_FLOAT_STACK(2, 4);
+
+ floatTop[1] = floatTop[-1];
+ floatTop[2] = *floatTop;
+ floatTop += 2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack over.
+ ** fover ( r1 r2 -- r1 r2 r1 )
+ *******************************************************************/
+ case ficlInstructionFOver:
+ {
+ CHECK_FLOAT_STACK(2, 3);
+
+ floatTop[1] = floatTop[-1];
+ floatTop++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2over.
+ ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Over:
+ {
+ CHECK_FLOAT_STACK(4, 6);
+
+ floatTop[1] = floatTop[-2];
+ floatTop[2] = floatTop[-1];
+ floatTop += 2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack pick.
+ ** fpick ( n -- r )
+ *******************************************************************/
+ case ficlInstructionFPick:
+ {
+ CHECK_STACK(1, 0);
+ c = *dataTop--;
+ CHECK_FLOAT_STACK(c.i+1, c.i+2);
+
+ floatTop[1] = floatTop[- c.i];
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack rot.
+ ** frot ( r1 r2 r3 -- r2 r3 r1 )
+ *******************************************************************/
+ case ficlInstructionFRot:
+ {
+ i = 2;
+ goto FROLL;
+ }
+
+ /*******************************************************************
+ ** Do float stack roll.
+ ** froll ( n -- )
+ *******************************************************************/
+ case ficlInstructionFRoll:
+ {
+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+FROLL:
+ CHECK_FLOAT_STACK(i+1, i+2);
+ c = floatTop[-i];
+ memmove(floatTop - i, floatTop - (i - 1), i * sizeof(ficlCell));
+ *floatTop = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack -rot.
+ ** f-rot ( r1 r2 r3 -- r3 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionFMinusRot:
+ {
+ i = 2;
+ goto FMINUSROLL;
+ }
+
+
+ /*******************************************************************
+ ** Do float stack -roll.
+ ** f-roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionFMinusRoll:
+ {
+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+FMINUSROLL:
+ CHECK_FLOAT_STACK(i+1, i+2);
+ c = *floatTop;
+ memmove(floatTop - (i - 1), floatTop - i, i * sizeof(ficlCell));
+ floatTop[-i] = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2swap
+ ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Swap:
+ {
+ ficlCell c2;
+ CHECK_FLOAT_STACK(4, 4);
+
+ c = *floatTop;
+ c2 = floatTop[-1];
+
+ *floatTop = floatTop[-2];
+ floatTop[-1] = floatTop[-3];
+
+ floatTop[-2] = c;
+ floatTop[-3] = c2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0= comparison r = 0.0.
+ ** f0= ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Equals:
+ {
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0< comparison r < 0.0.
+ ** f0< ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Less:
+ {
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0> comparison r > 0.0.
+ ** f0> ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Greater:
+ {
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float = comparison r1 = r2.
+ ** f= ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFEquals:
+ {
+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f == f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float < comparison r1 < r2.
+ ** f< ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFLess:
+ {
+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f < f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float > comparison r1 > r2.
+ ** f> ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFGreater:
+ {
+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f > f);
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Move float to param stack (assumes they both fit in a single ficlCell)
+ ** f>s
+ *******************************************************************/
+ case ficlInstructionFFrom:
+ {
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ *++dataTop = *floatTop--;
+ continue;
+ }
+
+ case ficlInstructionToF:
+ {
+ CHECK_FLOAT_STACK(0, 1);
+ CHECK_STACK(1, 0);
+
+ *++floatTop = *dataTop--;
+ continue;
+ }
+
+#endif /* FICL_WANT_FLOAT */
+
+
+ /**************************************************************************
+ c o l o n P a r e n
+ ** This is the code that executes a colon definition. It assumes that the
+ ** virtual machine is running a "next" loop (See the vm.c
+ ** for its implementation of member function vmExecute()). The colon
+ ** code simply copies the address of the first word in the list of words
+ ** to interpret into IP after saving its old value. When we return to the
+ ** "next" loop, the virtual machine will call the code for each word in
+ ** turn.
+ **
+ **************************************************************************/
+ case ficlInstructionColonParen:
+ {
+ (++returnTop)->p = (void *)ip;
+ ip = (ficlInstruction *)(fw->param);
+ continue;
+ }
+
+ case ficlInstructionCreateParen:
+ {
+ CHECK_STACK(0, 1);
+ (++dataTop)->p = (fw->param + 1);
+ continue;
+ }
+
+ case ficlInstructionVariableParen:
+ {
+ CHECK_STACK(0, 1);
+ (++dataTop)->p = fw->param;
+ continue;
+ }
+
+ /**************************************************************************
+ c o n s t a n t P a r e n
+ ** This is the run-time code for "constant". It simply returns the
+ ** contents of its word's first data ficlCell.
+ **
+ **************************************************************************/
+
+
+#if FICL_WANT_FLOAT
+ case ficlInstructionF2ConstantParen:
+ CHECK_FLOAT_STACK(0, 2);
+ FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param);
+
+ case ficlInstructionFConstantParen:
+ CHECK_FLOAT_STACK(0, 1);
+ FLOAT_PUSH_CELL_POINTER(fw->param);
+#endif /* FICL_WANT_FLOAT */
+
+ case ficlInstruction2ConstantParen:
+ CHECK_STACK(0, 2);
+ PUSH_CELL_POINTER_DOUBLE(fw->param);
+
+ case ficlInstructionConstantParen:
+ CHECK_STACK(0, 1);
+ PUSH_CELL_POINTER(fw->param);
+
+
+#if FICL_WANT_USER
+ case ficlInstructionUserParen:
+ {
+ ficlInteger i = fw->param[0].i;
+ (++dataTop)->p = &vm->user[i];
+ continue;
+ }
#endif
+ default:
+ {
+ /*
+ ** Clever hack, or evil coding? You be the judge.
+ **
+ ** If the word we've been asked to execute is in fact
+ ** an *instruction*, we grab the instruction, stow it
+ ** in "i" (our local cache of *ip), and *jump* to the
+ ** top of the switch statement. --lch
+ */
+ if ((ficlInstruction)fw->code < ficlInstructionLast)
+ {
+ instruction = (ficlInstruction)fw->code;
+ goto AGAIN;
+ }
+
+ LOCAL_VARIABLE_SPILL;
+ (vm)->runningWord = fw;
+ fw->code(vm);
+ LOCAL_VARIABLE_REFILL;
+ continue;
+ }
+ }
+ }
+
+ LOCAL_VARIABLE_SPILL;
+ vm->exceptionHandler = oldExceptionHandler;
+}
/**************************************************************************
v m G e t D i c t
** Returns the address dictionary for this VM's system
**************************************************************************/
-FICL_DICT *vmGetDict(FICL_VM *pVM)
+ficlDictionary *ficlVmGetDictionary(ficlVm *vm)
{
- assert(pVM);
- return pVM->pSys->dp;
+ FICL_VM_ASSERT(vm, vm);
+ return vm->callback.system->dictionary;
}
/**************************************************************************
v m G e t S t r i n g
** Parses a string out of the VM input buffer and copies up to the first
-** FICL_STRING_MAX characters to the supplied destination buffer, a
-** FICL_STRING. The destination string is NULL terminated.
+** FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a
+** ficlCountedString. The destination string is NULL terminated.
**
** Returns the address of the first unused character in the dest buffer.
**************************************************************************/
-char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
+char *ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter)
{
- STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
+ ficlString s = ficlVmParseStringEx(vm, delimiter, 0);
- if (SI_COUNT(si) > FICL_STRING_MAX)
+ if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX)
{
- SI_SETLEN(si, FICL_STRING_MAX);
+ FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX);
}
- strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
- spDest->text[SI_COUNT(si)] = '\0';
- spDest->count = (FICL_COUNT)SI_COUNT(si);
+ strncpy(counted->text, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
+ counted->text[FICL_STRING_GET_LENGTH(s)] = '\0';
+ counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
- return spDest->text + SI_COUNT(si) + 1;
+ return counted->text + FICL_STRING_GET_LENGTH(s) + 1;
}
@@ -282,16 +2361,16 @@ char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
** non-zero length.
**************************************************************************/
-STRINGINFO vmGetWord(FICL_VM *pVM)
+ficlString ficlVmGetWord(ficlVm *vm)
{
- STRINGINFO si = vmGetWord0(pVM);
+ ficlString s = ficlVmGetWord0(vm);
- if (SI_COUNT(si) == 0)
+ if (FICL_STRING_GET_LENGTH(s) == 0)
{
- vmThrow(pVM, VM_RESTART);
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
}
- return si;
+ return s;
}
@@ -304,44 +2383,38 @@ STRINGINFO vmGetWord(FICL_VM *pVM)
** does not use vmParseString because it uses isspace() rather than a
** single delimiter character.
**************************************************************************/
-STRINGINFO vmGetWord0(FICL_VM *pVM)
+ficlString ficlVmGetWord0(ficlVm *vm)
{
- char *pSrc = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- STRINGINFO si;
- FICL_UNS count = 0;
- char ch = 0;
+ char *trace = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ ficlString s;
+ ficlUnsigned length = 0;
+ char c = 0;
- pSrc = skipSpace(pSrc, pEnd);
- SI_SETPTR(si, pSrc);
+ trace = ficlStringSkipSpace(trace, stop);
+ FICL_STRING_SET_POINTER(s, trace);
-/*
- for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
- {
- count++;
- }
-*/
- /* Changed to make Purify happier. --lch */
+ /* Please leave this loop this way; it makes Purify happier. --lch */
for (;;)
{
- if (pEnd == pSrc)
- break;
- ch = *pSrc;
- if (isspace(ch))
- break;
- count++;
- pSrc++;
+ if (trace == stop)
+ break;
+ c = *trace;
+ if (isspace((unsigned char)c))
+ break;
+ length++;
+ trace++;
}
- SI_SETLEN(si, count);
+ FICL_STRING_SET_LENGTH(s, length);
- if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */
- pSrc++;
+ if ((trace != stop) && isspace((unsigned char)c)) /* skip one trailing delimiter */
+ trace++;
- vmUpdateTib(pVM, pSrc);
+ ficlVmUpdateTib(vm, trace);
- return si;
+ return s;
}
@@ -351,18 +2424,18 @@ STRINGINFO vmGetWord0(FICL_VM *pVM)
** string. Returns the length of the string. If the string is too long
** to fit in the pad, it is truncated.
**************************************************************************/
-int vmGetWordToPad(FICL_VM *pVM)
+int ficlVmGetWordToPad(ficlVm *vm)
{
- STRINGINFO si;
- char *cp = (char *)pVM->pad;
- si = vmGetWord(pVM);
+ ficlString s;
+ char *pad = (char *)vm->pad;
+ s = ficlVmGetWord(vm);
- if (SI_COUNT(si) > nPAD)
- SI_SETLEN(si, nPAD);
+ if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE)
+ FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE);
- strncpy(cp, SI_PTR(si), SI_COUNT(si));
- cp[SI_COUNT(si)] = '\0';
- return (int)(SI_COUNT(si));
+ strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
+ pad[FICL_STRING_GET_LENGTH(s)] = '\0';
+ return (int)(FICL_STRING_GET_LENGTH(s));
}
@@ -376,42 +2449,42 @@ int vmGetWordToPad(FICL_VM *pVM)
** Returns the address and length of the parsed string, not including the
** trailing delimiter.
**************************************************************************/
-STRINGINFO vmParseString(FICL_VM *pVM, char delim)
+ficlString ficlVmParseString(ficlVm *vm, char delimiter)
{
- return vmParseStringEx(pVM, delim, 1);
+ return ficlVmParseStringEx(vm, delimiter, 1);
}
-STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
+ficlString ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
{
- STRINGINFO si;
- char *pSrc = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- char ch;
+ ficlString s;
+ char *trace = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ char c;
- if (fSkipLeading)
- { /* skip lead delimiters */
- while ((pSrc != pEnd) && (*pSrc == delim))
- pSrc++;
+ if (skipLeadingDelimiters)
+ {
+ while ((trace != stop) && (*trace == delimiter))
+ trace++;
}
- SI_SETPTR(si, pSrc); /* mark start of text */
+ FICL_STRING_SET_POINTER(s, trace); /* mark start of text */
- for (ch = *pSrc; (pSrc != pEnd)
- && (ch != delim)
- && (ch != '\r')
- && (ch != '\n'); ch = *++pSrc)
+ for (c = *trace;
+ (trace != stop) && (c != delimiter)
+ && (c != '\r') && (c != '\n');
+ c = *++trace)
{
; /* find next delimiter or end of line */
}
/* set length of result */
- SI_SETLEN(si, pSrc - SI_PTR(si));
+ FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));
- if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
- pSrc++;
+ if ((trace != stop) && (*trace == delimiter)) /* gobble trailing delimiter */
+ trace++;
- vmUpdateTib(pVM, pSrc);
- return si;
+ ficlVmUpdateTib(vm, trace);
+ return s;
}
@@ -419,9 +2492,9 @@ STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
v m P o p
**
**************************************************************************/
-CELL vmPop(FICL_VM *pVM)
+ficlCell ficlVmPop(ficlVm *vm)
{
- return stackPop(pVM->pStack);
+ return ficlStackPop(vm->dataStack);
}
@@ -429,9 +2502,9 @@ CELL vmPop(FICL_VM *pVM)
v m P u s h
**
**************************************************************************/
-void vmPush(FICL_VM *pVM, CELL c)
+void ficlVmPush(ficlVm *vm, ficlCell c)
{
- stackPush(pVM->pStack, c);
+ ficlStackPush(vm->dataStack, c);
return;
}
@@ -440,9 +2513,9 @@ void vmPush(FICL_VM *pVM, CELL c)
v m P o p I P
**
**************************************************************************/
-void vmPopIP(FICL_VM *pVM)
+void ficlVmPopIP(ficlVm *vm)
{
- pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
+ vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
return;
}
@@ -451,10 +2524,10 @@ void vmPopIP(FICL_VM *pVM)
v m P u s h I P
**
**************************************************************************/
-void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
+void ficlVmPushIP(ficlVm *vm, ficlIp newIP)
{
- stackPushPtr(pVM->rStack, (void *)pVM->ip);
- pVM->ip = newIP;
+ ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
+ vm->ip = newIP;
return;
}
@@ -463,24 +2536,24 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
v m P u s h T i b
** Binds the specified input string to the VM and clears >IN (the index)
**************************************************************************/
-void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib)
+void ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
{
if (pSaveTib)
{
- *pSaveTib = pVM->tib;
+ *pSaveTib = vm->tib;
}
- pVM->tib.cp = text;
- pVM->tib.end = text + nChars;
- pVM->tib.index = 0;
+ vm->tib.text = text;
+ vm->tib.end = text + nChars;
+ vm->tib.index = 0;
}
-void vmPopTib(FICL_VM *pVM, TIB *pTib)
+void ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
{
if (pTib)
{
- pVM->tib = *pTib;
+ vm->tib = *pTib;
}
return;
}
@@ -490,18 +2563,18 @@ void vmPopTib(FICL_VM *pVM, TIB *pTib)
v m Q u i t
**
**************************************************************************/
-void vmQuit(FICL_VM *pVM)
-{
- stackReset(pVM->rStack);
- pVM->fRestart = 0;
- pVM->ip = NULL;
- pVM->runningWord = NULL;
- pVM->state = INTERPRET;
- pVM->tib.cp = NULL;
- pVM->tib.end = NULL;
- pVM->tib.index = 0;
- pVM->pad[0] = '\0';
- pVM->sourceID.i = 0;
+void ficlVmQuit(ficlVm *vm)
+{
+ ficlStackReset(vm->returnStack);
+ vm->restart = 0;
+ vm->ip = NULL;
+ vm->runningWord = NULL;
+ vm->state = FICL_VM_STATE_INTERPRET;
+ vm->tib.text = NULL;
+ vm->tib.end = NULL;
+ vm->tib.index = 0;
+ vm->pad[0] = '\0';
+ vm->sourceId.i = 0;
return;
}
@@ -510,14 +2583,14 @@ void vmQuit(FICL_VM *pVM)
v m R e s e t
**
**************************************************************************/
-void vmReset(FICL_VM *pVM)
+void ficlVmReset(ficlVm *vm)
{
- vmQuit(pVM);
- stackReset(pVM->pStack);
+ ficlVmQuit(vm);
+ ficlStackReset(vm->dataStack);
#if FICL_WANT_FLOAT
- stackReset(pVM->fStack);
+ ficlStackReset(vm->floatStack);
#endif
- pVM->base = 10;
+ vm->base = 10;
return;
}
@@ -527,273 +2600,489 @@ void vmReset(FICL_VM *pVM)
** Binds the specified output callback to the vm. If you pass NULL,
** binds the default output function (ficlTextOut)
**************************************************************************/
-void vmSetTextOut(FICL_VM *pVM, OUTFUNC textOut)
+void ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
{
- if (textOut)
- pVM->textOut = textOut;
- else
- pVM->textOut = ficlTextOut;
-
+ vm->callback.textOut = textOut;
return;
}
-/**************************************************************************
- v m T e x t O u t
-** Feeds text to the vm's output callback
-**************************************************************************/
-void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
-{
- assert(pVM);
- assert(pVM->textOut);
- (pVM->textOut)(pVM, text, fNewline);
+void ficlVmTextOut(ficlVm *vm, char *text)
+ {
+ ficlCallbackTextOut((ficlCallback *)vm, text);
+ }
- return;
-}
+void ficlVmErrorOut(ficlVm *vm, char *text)
+ {
+ ficlCallbackErrorOut((ficlCallback *)vm, text);
+ }
-/**************************************************************************
+
+ /**************************************************************************
v m T h r o w
**
**************************************************************************/
-void vmThrow(FICL_VM *pVM, int except)
+void ficlVmThrow(ficlVm *vm, int except)
{
- if (pVM->pState)
- longjmp(*(pVM->pState), except);
+ if (vm->exceptionHandler)
+ longjmp(*(vm->exceptionHandler), except);
}
-void vmThrowErr(FICL_VM *pVM, char *fmt, ...)
+void ficlVmThrowError(ficlVm *vm, char *fmt, ...)
{
- va_list va;
- va_start(va, fmt);
- vsprintf(pVM->pad, fmt, va);
- vmTextOut(pVM, pVM->pad, 1);
- va_end(va);
- longjmp(*(pVM->pState), VM_ERREXIT);
+ va_list list;
+
+ va_start(list, fmt);
+ vsprintf(vm->pad, fmt, list);
+ va_end(list);
+ strcat(vm->pad, "\n");
+
+ ficlVmErrorOut(vm, vm->pad);
+ longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
}
-/**************************************************************************
- w o r d I s I m m e d i a t e
-**
-**************************************************************************/
-int wordIsImmediate(FICL_WORD *pFW)
+void ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
{
- return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
+ vsprintf(vm->pad, fmt, list);
+ /* well, we can try anyway, we're certainly not returning to our caller! */
+ va_end(list);
+ strcat(vm->pad, "\n");
+
+ ficlVmErrorOut(vm, vm->pad);
+ longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
}
/**************************************************************************
- w o r d I s C o m p i l e O n l y
-**
+ f i c l E v a l u a t e
+** Wrapper for ficlExec() which sets SOURCE-ID to -1.
**************************************************************************/
-int wordIsCompileOnly(FICL_WORD *pFW)
+int ficlVmEvaluate(ficlVm *vm, char *s)
{
- return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
+ int returnValue;
+ ficlCell id = vm->sourceId;
+ ficlString string;
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_FROM_CSTRING(string, s);
+ returnValue = ficlVmExecuteString(vm, string);
+ vm->sourceId = id;
+ return returnValue;
}
/**************************************************************************
- s t r r e v
-**
+ f i c l E x e c
+** Evaluates a block of input text in the context of the
+** specified interpreter. Emits any requested output to the
+** interpreter's output function.
+**
+** Contains the "inner interpreter" code in a tight loop
+**
+** Returns one of the VM_XXXX codes defined in ficl.h:
+** VM_OUTOFTEXT is the normal exit condition
+** VM_ERREXIT means that the interpreter encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** VM_USEREXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
**************************************************************************/
-char *strrev( char *string )
-{ /* reverse a string in-place */
- int i = strlen(string);
- char *p1 = string; /* first char of string */
- char *p2 = string + i - 1; /* last non-NULL char of string */
- char c;
+int ficlVmExecuteString(ficlVm *vm, ficlString s)
+{
+ ficlSystem *system = vm->callback.system;
+ ficlDictionary *dictionary = system->dictionary;
+
+ int except;
+ jmp_buf vmState;
+ jmp_buf *oldState;
+ ficlTIB saveficlTIB;
+
+ FICL_VM_ASSERT(vm, vm);
+ FICL_VM_ASSERT(vm, system->interpreterLoop[0]);
+
+ ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s), &saveficlTIB);
+
+ /*
+ ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
+ */
+ oldState = vm->exceptionHandler;
+ vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */
+ except = setjmp(vmState);
- if (i > 1)
+ switch (except)
{
- while (p1 < p2)
+ case 0:
+ if (vm->restart)
{
- c = *p2;
- *p2 = *p1;
- *p1 = c;
- p1++; p2--;
+ vm->runningWord->code(vm);
+ vm->restart = 0;
+ }
+ else
+ { /* set VM up to interpret text */
+ ficlVmPushIP(vm, &(system->interpreterLoop[0]));
}
- }
-
- return string;
-}
+ ficlVmInnerLoop(vm, 0);
+ break;
-/**************************************************************************
- d i g i t _ t o _ c h a r
-**
-**************************************************************************/
-char digit_to_char(int value)
-{
- return digits[value];
+ case FICL_VM_STATUS_RESTART:
+ vm->restart = 1;
+ except = FICL_VM_STATUS_OUT_OF_TEXT;
+ break;
+
+ case FICL_VM_STATUS_OUT_OF_TEXT:
+ ficlVmPopIP(vm);
+ if ((vm->state != FICL_VM_STATE_COMPILE) && (vm->sourceId.i == 0))
+ ficlVmTextOut(vm, FICL_PROMPT);
+ break;
+
+ case FICL_VM_STATUS_USER_EXIT:
+ case FICL_VM_STATUS_INNER_EXIT:
+ case FICL_VM_STATUS_BREAK:
+ break;
+
+ case FICL_VM_STATUS_QUIT:
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ {
+ ficlDictionaryAbortDefinition(dictionary);
+#if FICL_WANT_LOCALS
+ ficlDictionaryEmpty(system->locals, system->locals->forthWordlist->size);
+#endif
+ }
+ ficlVmQuit(vm);
+ break;
+
+ case FICL_VM_STATUS_ERROR_EXIT:
+ case FICL_VM_STATUS_ABORT:
+ case FICL_VM_STATUS_ABORTQ:
+ default: /* user defined exit code?? */
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ {
+ ficlDictionaryAbortDefinition(dictionary);
+#if FICL_WANT_LOCALS
+ ficlDictionaryEmpty(system->locals, system->locals->forthWordlist->size);
+#endif
+ }
+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmReset(vm);
+ break;
+ }
+
+ vm->exceptionHandler = oldState;
+ ficlVmPopTib(vm, &saveficlTIB);
+ return (except);
}
/**************************************************************************
- i s P o w e r O f T w o
-** Tests whether supplied argument is an integer power of 2 (2**n)
-** where 32 > n > 1, and returns n if so. Otherwise returns zero.
+ f i c l E x e c X T
+** Given a pointer to a ficlWord, push an inner interpreter and
+** execute the word to completion. This is in contrast with vmExecute,
+** which does not guarantee that the word will have completed when
+** the function returns (ie in the case of colon definitions, which
+** need an inner interpreter to finish)
+**
+** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
+** exit condition is VM_INNEREXIT, Ficl's private signal to exit the
+** inner loop under normal circumstances. If another code is thrown to
+** exit the loop, this function will re-throw it if it's nested under
+** itself or ficlExec.
+**
+** NOTE: this function is intended so that C code can execute ficlWords
+** given their address in the dictionary (xt).
**************************************************************************/
-int isPowerOfTwo(FICL_UNS u)
+int ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
{
- int i = 1;
- FICL_UNS t = 2;
+ int except;
+ jmp_buf vmState;
+ jmp_buf *oldState;
+ ficlWord *oldRunningWord;
+
+ FICL_VM_ASSERT(vm, vm);
+ FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
+
+ /*
+ ** Save the runningword so that RESTART behaves correctly
+ ** over nested calls.
+ */
+ oldRunningWord = vm->runningWord;
+ /*
+ ** Save and restore VM's jmp_buf to enable nested calls
+ */
+ oldState = vm->exceptionHandler;
+ vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */
+ except = setjmp(vmState);
+
+ if (except)
+ ficlVmPopIP(vm);
+ else
+ ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
- for (; ((t <= u) && (t != 0)); i++, t <<= 1)
+ switch (except)
{
- if (u == t)
- return i;
+ case 0:
+ ficlVmExecuteWord(vm, pWord);
+ ficlVmInnerLoop(vm, 0);
+ break;
+
+ case FICL_VM_STATUS_INNER_EXIT:
+ case FICL_VM_STATUS_BREAK:
+ break;
+
+ case FICL_VM_STATUS_RESTART:
+ case FICL_VM_STATUS_OUT_OF_TEXT:
+ case FICL_VM_STATUS_USER_EXIT:
+ case FICL_VM_STATUS_QUIT:
+ case FICL_VM_STATUS_ERROR_EXIT:
+ case FICL_VM_STATUS_ABORT:
+ case FICL_VM_STATUS_ABORTQ:
+ default: /* user defined exit code?? */
+ if (oldState)
+ {
+ vm->exceptionHandler = oldState;
+ ficlVmThrow(vm, except);
+ }
+ break;
}
- return 0;
+ vm->exceptionHandler = oldState;
+ vm->runningWord = oldRunningWord;
+ return (except);
}
/**************************************************************************
- l t o a
-**
+ f i c l P a r s e N u m b e r
+** 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 FICL_TRUE. Otherwise, returns FICL_FALSE.
+** (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
+** the standard for DOUBLE wordset.
**************************************************************************/
-char *ltoa( FICL_INT value, char *string, int radix )
-{ /* convert long to string, any base */
- char *cp = string;
- int sign = ((radix == 10) && (value < 0));
- int pwr;
-
- assert(radix > 1);
- assert(radix < 37);
- assert(string);
-
- pwr = isPowerOfTwo((FICL_UNS)radix);
- if (sign)
- value = -value;
-
- if (value == 0)
- *cp++ = '0';
- else if (pwr != 0)
+int ficlVmParseNumber(ficlVm *vm, ficlString s)
+{
+ ficlInteger accumulator = 0;
+ char isNegative = 0;
+ char isDouble = 0;
+ unsigned base = vm->base;
+ char *trace = FICL_STRING_GET_POINTER(s);
+ ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
+ unsigned c;
+ unsigned digit;
+
+ if (length > 1)
{
- FICL_UNS v = (FICL_UNS) value;
- FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
- while (v)
+ switch (*trace)
{
- *cp++ = digits[v & mask];
- v >>= pwr;
+ case '-':
+ trace++;
+ length--;
+ isNegative = 1;
+ break;
+ case '+':
+ trace++;
+ length--;
+ isNegative = 0;
+ break;
+ default:
+ break;
}
}
- else
+
+ if ((length > 0) && (trace[length - 1] == '.')) /* detect & remove trailing decimal */
{
- UNSQR result;
- DPUNS v;
- v.hi = 0;
- v.lo = (FICL_UNS)value;
- while (v.lo)
- {
- result = ficlLongDiv(v, (FICL_UNS)radix);
- *cp++ = digits[result.rem];
- v.lo = result.quot;
- }
+ isDouble = 1;
+ length--;
}
- if (sign)
- *cp++ = '-';
+ if (length == 0) /* detect "+", "-", ".", "+." etc */
+ return 0; /* false */
- *cp++ = '\0';
+ while ((length--) && ((c = *trace++) != '\0'))
+ {
+ if (!isalnum(c))
+ return 0; /* false */
- return strrev(string);
-}
+ digit = c - '0';
+ if (digit > 9)
+ digit = tolower(c) - 'a' + 10;
-/**************************************************************************
- u l t o a
-**
-**************************************************************************/
-char *ultoa(FICL_UNS value, char *string, int radix )
-{ /* convert long to string, any base */
- char *cp = string;
- DPUNS ud;
- UNSQR result;
-
- assert(radix > 1);
- assert(radix < 37);
- assert(string);
-
- if (value == 0)
- *cp++ = '0';
- else
- {
- ud.hi = 0;
- ud.lo = value;
- result.quot = value;
+ if (digit >= base)
+ return 0; /* false */
- while (ud.lo)
- {
- result = ficlLongDiv(ud, (FICL_UNS)radix);
- ud.lo = result.quot;
- *cp++ = digits[result.rem];
- }
+ accumulator = accumulator * base + digit;
}
- *cp++ = '\0';
+ if (isDouble) /* simple (required) DOUBLE support */
+ ficlStackPushInteger(vm->dataStack, 0);
- return strrev(string);
+ if (isNegative)
+ accumulator = -accumulator;
+
+ ficlStackPushInteger(vm->dataStack, accumulator);
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ ficlPrimitiveLiteralIm(vm);
+
+ return 1; /* true */
}
+
+
+
/**************************************************************************
- c a s e F o l d
-** Case folds a NULL terminated string in place. All characters
-** get converted to lower case.
+ d i c t C h e c k
+** Checks the dictionary for corruption and throws appropriate
+** errors.
+** Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
+** -n number of ADDRESS UNITS proposed to de-allot
+** 0 just do a consistency check
**************************************************************************/
-char *caseFold(char *cp)
+void ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
+#if FICL_ROBUST >= 1
{
- char *oldCp = cp;
+ if ((cells >= 0) && (ficlDictionaryCellsAvailable(dictionary) * (int)sizeof(ficlCell) < cells))
+ {
+ ficlVmThrowError(vm, "Error: dictionary full");
+ }
- while (*cp)
+ if ((cells <= 0) && (ficlDictionaryCellsUsed(dictionary) * (int)sizeof(ficlCell) < -cells))
{
- if (isupper(*cp))
- *cp = (char)tolower(*cp);
- cp++;
+ ficlVmThrowError(vm, "Error: dictionary underflow");
}
- return oldCp;
+ return;
}
+#else /* FICL_ROBUST >= 1 */
+{
+ FICL_IGNORE(vm);
+ FICL_IGNORE(dictionary);
+ FICL_IGNORE(cells);
+}
+#endif /* FICL_ROBUST >= 1 */
-/**************************************************************************
- s t r i n c m p
-** (jws) simplified the code a bit in hopes of appeasing Purify
-**************************************************************************/
-int strincmp(char *cp1, char *cp2, FICL_UNS count)
+void ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
+#if FICL_ROBUST >= 1
{
- int i = 0;
+ ficlVmDictionarySimpleCheck(vm, dictionary, cells);
- for (; 0 < count; ++cp1, ++cp2, --count)
+ if (dictionary->wordlistCount > FICL_MAX_WORDLISTS)
+ {
+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmThrowError(vm, "Error: search order overflow");
+ }
+ else if (dictionary->wordlistCount < 0)
{
- i = tolower(*cp1) - tolower(*cp2);
- if (i != 0)
- return i;
- else if (*cp1 == '\0')
- return 0;
+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmThrowError(vm, "Error: search order underflow");
}
- return 0;
+
+ return;
+}
+#else /* FICL_ROBUST >= 1 */
+{
+ FICL_IGNORE(vm);
+ FICL_IGNORE(dictionary);
+ FICL_IGNORE(cells);
+}
+#endif /* FICL_ROBUST >= 1 */
+
+
+
+void ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
+{
+ FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
+ FICL_IGNORE(vm);
+ ficlDictionaryAllot(dictionary, n);
+}
+
+
+void ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
+{
+ FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
+ FICL_IGNORE(vm);
+ ficlDictionaryAllotCells(dictionary, cells);
}
+
/**************************************************************************
- s k i p S p a c e
-** Given a string pointer, returns a pointer to the first non-space
-** char of the string, or to the NULL terminator if no such char found.
-** If the pointer reaches "end" first, stop there. Pass NULL to
-** suppress this behavior.
+ f i c l P a r s e W o r d
+** From the standard, section 3.4
+** b) Search the dictionary name space (see 3.4.2). If a definition name
+** matching the string is found:
+** 1.if interpreting, perform the interpretation semantics of the definition
+** (see 3.4.3.2), and continue at a);
+** 2.if compiling, perform the compilation semantics of the definition
+** (see 3.4.3.3), and continue at a).
+**
+** c) If a definition name matching the string is not found, attempt to
+** convert the string to a number (see 3.4.1.3). If successful:
+** 1.if interpreting, place the number on the data stack, and continue at a);
+** 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place the number on
+** the stack (see 6.1.1780 LITERAL), and continue at a);
+**
+** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
+**
+** (jws 4/01) Modified to be a ficlParseStep
**************************************************************************/
-char *skipSpace(char *cp, char *end)
+int ficlVmParseWord(ficlVm *vm, ficlString name)
{
- assert(cp);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *tempFW;
+
+ FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
+ FICL_STACK_CHECK(vm->dataStack, 0, 0);
+
+#if FICL_WANT_LOCALS
+ if (vm->callback.system->localsCount > 0)
+ {
+ tempFW = ficlSystemLookupLocal(vm->callback.system, name);
+ }
+ else
+#endif
+ tempFW = ficlDictionaryLookup(dictionary, name);
- while ((cp != end) && isspace(*cp))
- cp++;
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {
+ if (tempFW != NULL)
+ {
+ if (ficlWordIsCompileOnly(tempFW))
+ {
+ ficlVmThrowError(vm, "Error: FICL_VM_STATE_COMPILE only!");
+ }
+
+ ficlVmExecuteWord(vm, tempFW);
+ return 1; /* true */
+ }
+ }
+
+ else /* (vm->state == FICL_VM_STATE_COMPILE) */
+ {
+ if (tempFW != NULL)
+ {
+ if (ficlWordIsImmediate(tempFW))
+ {
+ ficlVmExecuteWord(vm, tempFW);
+ }
+ else
+ {
+ if (tempFW->flags & FICL_WORD_INSTRUCTION)
+ ficlDictionaryAppendUnsigned(dictionary, (ficlInteger)tempFW->code);
+ else
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(tempFW));
+ }
+ return 1; /* true */
+ }
+ }
- return cp;
+ return 0; /* false */
}
diff --git a/win32.c b/win32.c
deleted file mode 100644
index 7b9c44b38db9..000000000000
--- a/win32.c
+++ /dev/null
@@ -1,406 +0,0 @@
-/*
- * win32.c
- * submitted to Ficl by Larry Hastings, larry@hastings.org
- * Additional Win32 words by Guy Carver
- *
- * adds calling arbitrary DLL function calls from inside Ficl.
- *
- * note that Microsoft's own header files won't compile without
- * "language extensions" (anonymous structs/unions) turned on.
- * and even with that, it still gives a warning in rpcasync.h
- * for something that compiles clean in C++. I turned it off.
- *
- */
-#pragma warning(disable : 4115)
-#include <stdio.h>
-#include <windows.h>
-#include <string.h>
-#include <direct.h>
-
-#include "ficl.h"
-
-static void loadLibrary(FICL_VM *pVM) /* ( address length -- hmodule ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)_alloca(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
-
- stackPushINT(pVM->pStack, (int)LoadLibrary(buf));
-}
-
-static void getProcAddress(FICL_VM *pVM) /* ( address length hmodule -- ) */
-{
- HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)_alloca(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
-
- stackPushINT(pVM->pStack, (int)GetProcAddress(hModule, buf));
-}
-
-
-static void freeLibrary(FICL_VM *pVM) /* ( hmodule -- ) */
-{
- HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
- FreeLibrary(hModule);
-}
-
-
-static void uAddrToCString(FICL_VM *pVM) /* ( address length -- c-string ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)malloc(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
- stackPushPtr(pVM->pStack, buf);
- return;
-}
-
-
-static void callNativeFunction(FICL_VM *pVM) /* ( ... argcount fnaddress popstack -- returnvalue ) */
-{
- int popstack = stackPopINT(pVM->pStack);
- int fnaddress = stackPopINT(pVM->pStack);
- int argcount = stackPopINT(pVM->pStack);
- int returnvalue;
-
- int i;
- for (i = 0; i < argcount; i++)
- {
- int nextarg = stackPopINT(pVM->pStack);
- __asm
- {
- mov eax, nextarg
- push eax
- }
- }
-
-
- __asm
- {
- call fnaddress
- mov returnvalue, eax
- }
-
- /*
- * if popstack is nonzero,
- * the arguments are popped off the stack after calling
- */
- if (popstack)
- {
- argcount *= 4;
- __asm add esp, argcount
- }
- stackPushINT(pVM->pStack, returnvalue);
- return;
-}
-
-
-/**************************************************************************
- v c a l l
-** Call a class method. (Contributed by Guy Carver)
-** FORTH: (params inst paramcnt vtableindex -- res )
-** INFO: paramcnt has msb set if return value is desired.
-**************************************************************************/
-static void VCall(FICL_VM *pVM)
-{
- int ind,p,paramCnt;
- void *instance;
- int I;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,1);
-#endif
-
- ind = POPINT() * 4;
- paramCnt = POPINT();
- instance = POPPTR(); //Get instance of class.
-
- __asm push ecx //Save ecx.
- __asm push esp //Save stack.
-
- I = paramCnt & 0xFF; //Strip off any flags.
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,I,0);
-#endif
-
- while(I--) //Loop for parameter count.
- {
- p = POPINT();
- __asm
- {
- mov eax,p
- push eax //Push on stack.
- }
- }
- __asm
- {
- mov ecx,instance //Set ecx to instance.
- mov eax,[ecx] //Get method pointer.
- add eax,ind
- call [eax] //Call method.
- mov p,eax //Put result in p.
- pop esp
- pop ecx //Restore ecx and esp.
- }
- if (paramCnt & 0x80000000) //If supposed to return a result.
- PUSHINT(p); //Store result.
-}
-
-
-#if 0
-//**************************************************************
-//Load forth file.
-//ENTER: pVM = Pointer to forth virtual machine.
-//FORTH: ( -<FileName>- )
-//**************************************************************
-static void ForthLoad(FICL_VM *pVM)
-{
- char cp[256];
- char fileName[256];
- FILE *fp;
- int result = 0;
- CELL id;
- int nLine = 0;
- FICL_STRING *pFileName = (FICL_STRING *)fileName;
-
- vmGetString(pVM,pFileName, ' ');
-
- if (pFileName->count <= 0)
- {
- vmTextOut(pVM,"Type fload filename", 1);
- return;
- }
-
- fp = fopen(pFileName->text, "r");
- if (fp)
- {
- id = pVM->sourceID;
- pVM->sourceID.p = (void *)fp; //Set input source id.
-
- while (fgets(cp,256,fp)) //Read line.
- {
- int len = strlen(cp) - 1; //Get length.
-
- nLine++; //Inc line count.
- if (len > 0) //if length.
- {
- cp[len] = 0; //Make sure null terminated.
- result = ficlExec(pVM,cp); //Execute line.
- if ((result == VM_ERREXIT) //If exit.
- || (result == VM_USEREXIT)
- || (result == VM_QUIT))
- {
- pVM->sourceID = id;
- fclose(fp);
- vmThrowErr(pVM, "Error loading file <%s> line %d", pFileName->text, nLine);
- break;
- }
- }
- }
- pVM->sourceID.i = -1;
- ficlExec(pVM,""); //Empty line to flush any pending refills.
- pVM->sourceID = id; //Reset source ID.
- fclose(fp);
- if (result == VM_USEREXIT) //If user exit.
- vmThrow(pVM,VM_USEREXIT); //Resend user exit code.
- }
- else
- {
- vmTextOut(pVM,"Unable to open file: ", 0);
- vmTextOut(pVM, pFileName->text,1);
- }
-}
-
-//********************************************************************************
-//
-//********************************************************************************
-static STRINGINFO parseFileName(FICL_VM *pVM)
-{
- STRINGINFO si;
- char *pSrc = vmGetInBuf(pVM);
- si.cp = pSrc; /* mark start of text */
- while ((*pSrc != ' ') && (*pSrc != 0) && (*pSrc != '\n'))
- {
- if (*(pSrc++) == '\\') /* find next delimiter or end */
- si.cp = pSrc;
- }
- si.count = pSrc - si.cp; /* set length of result */
- return(si);
-}
-
-//********************************************************************************
-//check for included file and load if not loaded.
-//********************************************************************************
-static void include(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code;
-
- si = parseFileName(pVM);
-
- if (si.count)
- {
- pFW = dictLookup(dp, si);
- if (!pFW) //Forget word.
- {
- dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- ForthLoad(pVM);
- }
- }
-}
-
-//********************************************************************************
-//check for included file and kill it if its included to reload.
-//********************************************************************************
-static void reinclude(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code;
-
- si = parseFileName(pVM);
-
- if (si.count)
- {
- pFW = dictLookup(dp, si);
- if (pFW) //Forget word.
- {
- hashForget(dp->pCompile,pFW->name);
- dp->here = PTRtoCELL (pFW->name);
- }
-
- dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- ForthLoad(pVM);
- }
-}
-
-#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
-**************************************************************************/
-void ficlCompilePlatform(FICL_SYSTEM *pSys)
-{
- FICL_DICT *dp = pSys->dp;
- assert (dp);
-
- dictAppendWord(dp, "loadlibrary", loadLibrary, FW_DEFAULT);
- dictAppendWord(dp, "getprocaddress", getProcAddress, FW_DEFAULT);
- dictAppendWord(dp, "freelibrary", freeLibrary, FW_DEFAULT);
- dictAppendWord(dp, "uaddr->cstring", uAddrToCString, FW_DEFAULT);
- dictAppendWord(dp, "callnativefunction",
- 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
-
-
-
-
diff --git a/word.c b/word.c
new file mode 100644
index 000000000000..ae24717a9013
--- /dev/null
+++ b/word.c
@@ -0,0 +1,144 @@
+#include "ficl.h"
+
+
+/**************************************************************************
+ w o r d I s I m m e d i a t e
+**
+**************************************************************************/
+int ficlWordIsImmediate(ficlWord *word)
+{
+ return ((word != NULL) && (word->flags & FICL_WORD_IMMEDIATE));
+}
+
+
+/**************************************************************************
+ w o r d I s C o m p i l e O n l y
+**
+**************************************************************************/
+int ficlWordIsCompileOnly(ficlWord *word)
+{
+ return ((word != NULL) && (word->flags & FICL_WORD_COMPILE_ONLY));
+}
+
+
+/**************************************************************************
+ f i c l W o r d C l a s s i f y
+** This public function helps to classify word types for SEE
+** and the debugger in tools.c. Given an pointer to a word, it returns
+** a member of WOR
+**************************************************************************/
+ficlWordKind ficlWordClassify(ficlWord *word)
+{
+ ficlPrimitive code;
+ ficlInstruction i;
+ ficlWordKind iType;
+
+ if ( (((ficlInstruction)word) > ficlInstructionInvalid)
+ && (((ficlInstruction)word) < ficlInstructionLast) )
+ {
+ i = (ficlInstruction)word;
+ iType = FICL_WORDKIND_INSTRUCTION;
+ goto IS_INSTRUCTION;
+ }
+
+ code = word->code;
+
+ if ((ficlInstruction)code < ficlInstructionLast)
+ {
+ i = (ficlInstruction)code;
+ iType = FICL_WORDKIND_INSTRUCTION_WORD;
+ goto IS_INSTRUCTION;
+ }
+
+ return FICL_WORDKIND_PRIMITIVE;
+
+IS_INSTRUCTION:
+
+ switch (i)
+ {
+ case ficlInstructionConstantParen:
+#if FICL_WANT_FLOAT
+ case ficlInstructionFConstantParen:
+#endif /* FICL_WANT_FLOAT */
+ return FICL_WORDKIND_CONSTANT;
+
+ case ficlInstruction2ConstantParen:
+#if FICL_WANT_FLOAT
+ case ficlInstructionF2ConstantParen:
+#endif /* FICL_WANT_FLOAT */
+ return FICL_WORDKIND_2CONSTANT;
+
+#if FICL_WANT_LOCALS
+ case ficlInstructionToLocalParen:
+ case ficlInstructionTo2LocalParen:
+#if FICL_WANT_FLOAT
+ case ficlInstructionToFLocalParen:
+ case ficlInstructionToF2LocalParen:
+#endif /* FICL_WANT_FLOAT */
+ return FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT;
+#endif /* FICL_WANT_LOCALS */
+
+#if FICL_WANT_USER
+ case ficlInstructionUserParen:
+ return FICL_WORDKIND_USER;
+#endif
+
+ case ficlInstruction2LiteralParen:
+ return FICL_WORDKIND_2LITERAL;
+
+#if FICL_WANT_FLOAT
+ case ficlInstructionFLiteralParen:
+ return FICL_WORDKIND_FLITERAL;
+#endif
+
+ case ficlInstructionCreateParen:
+ return FICL_WORDKIND_CREATE;
+
+ case ficlInstructionCStringLiteralParen:
+ return FICL_WORDKIND_CSTRING_LITERAL;
+
+ case ficlInstructionStringLiteralParen:
+ return FICL_WORDKIND_STRING_LITERAL;
+
+ case ficlInstructionColonParen:
+ return FICL_WORDKIND_COLON;
+
+ case ficlInstructionDoDoes:
+ return FICL_WORDKIND_DOES;
+
+ case ficlInstructionDoParen:
+ return FICL_WORDKIND_DO;
+
+ case ficlInstructionQDoParen:
+ return FICL_WORDKIND_QDO;
+
+ case ficlInstructionVariableParen:
+ return FICL_WORDKIND_VARIABLE;
+
+ case ficlInstructionBranchParenWithCheck:
+ case ficlInstructionBranchParen:
+ return FICL_WORDKIND_BRANCH;
+
+ case ficlInstructionBranch0ParenWithCheck:
+ case ficlInstructionBranch0Paren:
+ return FICL_WORDKIND_BRANCH0;
+
+ case ficlInstructionLiteralParen:
+ return FICL_WORDKIND_LITERAL;
+
+ case ficlInstructionLoopParen:
+ return FICL_WORDKIND_LOOP;
+
+ case ficlInstructionOfParen:
+ return FICL_WORDKIND_OF;
+
+ case ficlInstructionPlusLoopParen:
+ return FICL_WORDKIND_PLOOP;
+
+ default:
+ return iType;
+ }
+}
+
+
+
diff --git a/words.c b/words.c
deleted file mode 100644
index 4d1a5a3fa5b7..000000000000
--- a/words.c
+++ /dev/null
@@ -1,5201 +0,0 @@
-/*******************************************************************
-** w o r d s . c
-** Forth Inspired Command Language
-** 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.17 2001-12-04 17:58:10-08 jsadler Exp jsadler $
-*******************************************************************/
-/*
-** 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
-** 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 <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <ctype.h>
-#include "ficl.h"
-#include "math64.h"
-
-static void colonParen(FICL_VM *pVM);
-static void literalIm(FICL_VM *pVM);
-static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
-
-/*
-** Control structure building words use these
-** strings' addresses as markers on the stack to
-** check for structure completion.
-*/
-static char doTag[] = "do";
-static char colonTag[] = "colon";
-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);
-#endif
-
-
-/*
-** C O N T R O L S T R U C T U R E B U I L D E R S
-**
-** Push current dict location for later branch resolution.
-** The location may be either a branch target or a patch address...
-*/
-static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- PUSHPTR(dp->here);
- PUSHPTR(tag);
- return;
-}
-
-static void markControlTag(FICL_VM *pVM, char *tag)
-{
- PUSHPTR(tag);
- return;
-}
-
-static void matchControlTag(FICL_VM *pVM, char *tag)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- cp = (char *)stackPopPtr(pVM->pStack);
- /*
- ** Changed the code below to compare the pointers first (by popular demand)
- */
- if ( (cp != tag) && strcmp(cp, tag) )
- {
- vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
- }
-
- return;
-}
-
-/*
-** Expect a branch target address on the param stack,
-** compile a literal offset from the current dict location
-** to the target address
-*/
-static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- FICL_INT offset;
- CELL *patchAddr;
-
- matchControlTag(pVM, tag);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- offset = patchAddr - dp->here;
- dictAppendCell(dp, LVALUEtoCELL(offset));
-
- return;
-}
-
-
-/*
-** Expect a branch patch address on the param stack,
-** compile a literal offset from the patch location
-** to the current dict location
-*/
-static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- FICL_INT offset;
- CELL *patchAddr;
-
- matchControlTag(pVM, tag);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- offset = dp->here - patchAddr;
- *patchAddr = LVALUEtoCELL(offset);
-
- return;
-}
-
-/*
-** Match the tag to the top of the stack. If success,
-** sopy "here" address into the cell whose address is next
-** on the stack. Used by do..leave..loop.
-*/
-static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- CELL *patchAddr;
- char *cp;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- cp = stackPopPtr(pVM->pStack);
- /*
- ** Changed the comparison below to compare the pointers first (by popular demand)
- */
- if ((cp != tag) && strcmp(cp, tag))
- {
- vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
- vmTextOut(pVM, tag, 1);
- }
-
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- *patchAddr = LVALUEtoCELL(dp->here);
-
- return;
-}
-
-
-/**************************************************************************
- f i c l P a r s e N u m b e r
-** 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)
-{
- 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);
- unsigned ch;
- unsigned digit;
-
- if (count > 1)
- {
- switch (*cp)
- {
- case '-':
- cp++;
- count--;
- isNeg = TRUE;
- break;
- case '+':
- cp++;
- count--;
- isNeg = FALSE;
- break;
- default:
- break;
- }
- }
-
- 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'))
- {
- if (!isalnum(ch))
- return FALSE;
-
- digit = ch - '0';
-
- if (digit > 9)
- digit = tolower(ch) - 'a' + 10;
-
- if (digit >= base)
- return FALSE;
-
- accum = accum * base + digit;
- }
-
- if (hasDP) /* simple (required) DOUBLE support */
- PUSHINT(0);
-
- if (isNeg)
- accum = -accum;
-
- PUSHINT(accum);
- if (pVM->state == COMPILE)
- literalIm(pVM);
-
- return TRUE;
-}
-
-
-/**************************************************************************
- a d d & f r i e n d s
-**
-**************************************************************************/
-
-static void add(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i += stackGetTop(pVM->pStack).i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void sub(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i = stackGetTop(pVM->pStack).i - i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void mul(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i *= stackGetTop(pVM->pStack).i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void negate(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = -stackPopINT(pVM->pStack);
- PUSHINT(i);
- return;
-}
-
-static void ficlDiv(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i = stackGetTop(pVM->pStack).i / i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-/*
-** slash-mod CORE ( n1 n2 -- n3 n4 )
-** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
-** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
-** differ in sign, the implementation-defined result returned will be the
-** same as that returned by either the phrase
-** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
-** NOTE: Ficl complies with the second phrase (symmetric division)
-*/
-static void slashMod(FICL_VM *pVM)
-{
- DPINT n1;
- FICL_INT n2;
- INTQR qr;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
- n2 = stackPopINT(pVM->pStack);
- n1.lo = stackPopINT(pVM->pStack);
- i64Extend(n1);
-
- qr = m64SymmetricDivI(n1, n2);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-static void onePlus(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i += 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void oneMinus(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i -= 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void twoMul(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i *= 2;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void twoDiv(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i >>= 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void mulDiv(FICL_VM *pVM)
-{
- FICL_INT x, y, z;
- DPINT prod;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 1);
-#endif
- z = stackPopINT(pVM->pStack);
- y = stackPopINT(pVM->pStack);
- x = stackPopINT(pVM->pStack);
-
- prod = m64MulI(x,y);
- x = m64SymmetricDivI(prod, z).quot;
-
- PUSHINT(x);
- return;
-}
-
-
-static void mulDivRem(FICL_VM *pVM)
-{
- FICL_INT x, y, z;
- DPINT prod;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 2);
-#endif
- z = stackPopINT(pVM->pStack);
- y = stackPopINT(pVM->pStack);
- x = stackPopINT(pVM->pStack);
-
- prod = m64MulI(x,y);
- qr = m64SymmetricDivI(prod, z);
-
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- c o l o n d e f i n i t i o n s
-** Code to begin compiling a colon definition
-** This function sets the state to COMPILE, then creates a
-** new word whose name is the next word in the input stream
-** and whose code is colonParen.
-**************************************************************************/
-
-static void colon(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- pVM->state = COMPILE;
- markControlTag(pVM, colonTag);
- dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
-#if FICL_WANT_LOCALS
- pVM->pSys->nLocals = 0;
-#endif
- return;
-}
-
-
-/**************************************************************************
- c o l o n P a r e n
-** This is the code that executes a colon definition. It assumes that the
-** virtual machine is running a "next" loop (See the vm.c
-** for its implementation of member function vmExecute()). The colon
-** code simply copies the address of the first word in the list of words
-** to interpret into IP after saving its old value. When we return to the
-** "next" loop, the virtual machine will call the code for each word in
-** turn.
-**
-**************************************************************************/
-
-static void colonParen(FICL_VM *pVM)
-{
- IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
- vmPushIP(pVM, tempIP);
-
- return;
-}
-
-
-/**************************************************************************
- s e m i c o l o n C o I m
-**
-** IMMEDIATE code for ";". This function sets the state to INTERPRET and
-** terminates a word under compilation by appending code for "(;)" to
-** the definition. TO DO: checks for leftover branch target tags on the
-** return stack and complains if any are found.
-**************************************************************************/
-static void semiParen(FICL_VM *pVM)
-{
- vmPopIP(pVM);
- return;
-}
-
-
-static void semicolonCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pSemiParen);
- matchControlTag(pVM, colonTag);
-
-#if FICL_WANT_LOCALS
- assert(pVM->pSys->pUnLinkParen);
- if (pVM->pSys->nLocals > 0)
- {
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
- pVM->pSys->nLocals = 0;
-#endif
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
- pVM->state = INTERPRET;
- dictUnsmudge(dp);
- return;
-}
-
-
-/**************************************************************************
- e x i t
-** CORE
-** This function simply pops the previous instruction
-** pointer and returns to the "next" loop. Used for exiting from within
-** a definition. Note that exitParen is identical to semiParen - they
-** are in two different functions so that "see" can correctly identify
-** the end of a colon definition, even if it uses "exit".
-**************************************************************************/
-static void exitParen(FICL_VM *pVM)
-{
- vmPopIP(pVM);
- return;
-}
-
-static void exitCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pExitParen);
- IGNORE(pVM);
-
-#if FICL_WANT_LOCALS
- if (pVM->pSys->nLocals > 0)
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
-#endif
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
- return;
-}
-
-
-/**************************************************************************
- c o n s t a n t P a r e n
-** This is the run-time code for "constant". It simply returns the
-** contents of its word's first data cell.
-**
-**************************************************************************/
-
-void constantParen(FICL_VM *pVM)
-{
- FICL_WORD *pFW = pVM->runningWord;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- stackPush(pVM->pStack, pFW->param[0]);
- return;
-}
-
-void twoConstParen(FICL_VM *pVM)
-{
- FICL_WORD *pFW = pVM->runningWord;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, pFW->param[0]); /* lo */
- stackPush(pVM->pStack, pFW->param[1]); /* hi */
- return;
-}
-
-
-/**************************************************************************
- c o n s t a n t
-** IMMEDIATE
-** Compiles a constant into the dictionary. Constants return their
-** value when invoked. Expects a value on top of the parm stack.
-**************************************************************************/
-
-static void constant(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
- dictAppendCell(dp, stackPop(pVM->pStack));
- return;
-}
-
-
-static void twoConstant(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- c = stackPop(pVM->pStack);
- dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
- dictAppendCell(dp, stackPop(pVM->pStack));
- dictAppendCell(dp, c);
- return;
-}
-
-
-/**************************************************************************
- d i s p l a y C e l l
-** Drop and print the contents of the cell at the top of the param
-** stack
-**************************************************************************/
-
-static void displayCell(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- c = stackPop(pVM->pStack);
- ltoa((c).i, pVM->pad, pVM->base);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-static void uDot(FICL_VM *pVM)
-{
- FICL_UNS u;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- u = stackPopUNS(pVM->pStack);
- ultoa(u, pVM->pad, pVM->base);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-
-static void hexDot(FICL_VM *pVM)
-{
- FICL_UNS u;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- u = stackPopUNS(pVM->pStack);
- ultoa(u, pVM->pad, 16);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-
-/**************************************************************************
- 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
-**
-**************************************************************************/
-
-static void depth(FICL_VM *pVM)
-{
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- i = stackDepth(pVM->pStack);
- PUSHINT(i);
- return;
-}
-
-
-static void drop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- stackDrop(pVM->pStack, 1);
- return;
-}
-
-
-static void twoDrop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- stackDrop(pVM->pStack, 2);
- return;
-}
-
-
-static void dup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- stackPick(pVM->pStack, 0);
- return;
-}
-
-
-static void twoDup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 4);
-#endif
- stackPick(pVM->pStack, 1);
- stackPick(pVM->pStack, 1);
- return;
-}
-
-
-static void over(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 3);
-#endif
- stackPick(pVM->pStack, 1);
- return;
-}
-
-static void twoOver(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 4, 6);
-#endif
- stackPick(pVM->pStack, 3);
- stackPick(pVM->pStack, 3);
- return;
-}
-
-
-static void pick(FICL_VM *pVM)
-{
- CELL c = stackPop(pVM->pStack);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, c.i+1, c.i+2);
-#endif
- stackPick(pVM->pStack, c.i);
- return;
-}
-
-
-static void questionDup(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- c = stackGetTop(pVM->pStack);
-
- if (c.i != 0)
- stackPick(pVM->pStack, 0);
-
- return;
-}
-
-
-static void roll(FICL_VM *pVM)
-{
- int i = stackPop(pVM->pStack).i;
- i = (i > 0) ? i : 0;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, i+1, i+1);
-#endif
- stackRoll(pVM->pStack, i);
- return;
-}
-
-
-static void minusRoll(FICL_VM *pVM)
-{
- int i = stackPop(pVM->pStack).i;
- i = (i > 0) ? i : 0;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, i+1, i+1);
-#endif
- stackRoll(pVM->pStack, -i);
- return;
-}
-
-
-static void rot(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 3);
-#endif
- stackRoll(pVM->pStack, 2);
- return;
-}
-
-
-static void swap(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
- stackRoll(pVM->pStack, 1);
- return;
-}
-
-
-static void twoSwap(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 4, 4);
-#endif
- stackRoll(pVM->pStack, 3);
- stackRoll(pVM->pStack, 3);
- return;
-}
-
-
-/**************************************************************************
- e m i t & f r i e n d s
-**
-**************************************************************************/
-
-static void emit(FICL_VM *pVM)
-{
- char *cp = pVM->pad;
- int i;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- i = stackPopINT(pVM->pStack);
- cp[0] = (char)i;
- cp[1] = '\0';
- vmTextOut(pVM, cp, 0);
- return;
-}
-
-
-static void cr(FICL_VM *pVM)
-{
- vmTextOut(pVM, "", 1);
- return;
-}
-
-
-static void commentLine(FICL_VM *pVM)
-{
- char *cp = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- char ch = *cp;
-
- while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
- {
- ch = *++cp;
- }
-
- /*
- ** Cope with DOS or UNIX-style EOLs -
- ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
- ** and point cp to next char. If EOL is \0, we're done.
- */
- if (cp != pEnd)
- {
- cp++;
-
- if ( (cp != pEnd) && (ch != *cp)
- && ((*cp == '\r') || (*cp == '\n')) )
- cp++;
- }
-
- vmUpdateTib(pVM, cp);
- return;
-}
-
-
-/*
-** paren CORE
-** Compilation: Perform the execution semantics given below.
-** Execution: ( "ccc<paren>" -- )
-** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
-** The number of characters in ccc may be zero to the number of characters
-** in the parse area.
-**
-*/
-static void commentHang(FICL_VM *pVM)
-{
- vmParseStringEx(pVM, ')', 0);
- return;
-}
-
-
-/**************************************************************************
- F E T C H & S T O R E
-**
-**************************************************************************/
-
-static void fetch(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- stackPush(pVM->pStack, *pCell);
- return;
-}
-
-/*
-** two-fetch CORE ( a-addr -- x1 x2 )
-** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
-** x1 at the next consecutive cell. It is equivalent to the sequence
-** DUP CELL+ @ SWAP @ .
-*/
-static void twoFetch(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- stackPush(pVM->pStack, *pCell++);
- stackPush(pVM->pStack, *pCell);
- swap(pVM);
- return;
-}
-
-/*
-** store CORE ( x a-addr -- )
-** Store x at a-addr.
-*/
-static void store(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- *pCell = stackPop(pVM->pStack);
-}
-
-/*
-** two-store CORE ( x1 x2 a-addr -- )
-** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
-** next consecutive cell. It is equivalent to the sequence
-** SWAP OVER ! CELL+ ! .
-*/
-static void twoStore(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- *pCell++ = stackPop(pVM->pStack);
- *pCell = stackPop(pVM->pStack);
-}
-
-static void plusStore(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- pCell->i += stackPop(pVM->pStack).i;
-}
-
-
-static void quadFetch(FICL_VM *pVM)
-{
- UNS32 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pw = (UNS32 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pw);
- return;
-}
-
-static void quadStore(FICL_VM *pVM)
-{
- UNS32 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pw = (UNS32 *)stackPopPtr(pVM->pStack);
- *pw = (UNS32)(stackPop(pVM->pStack).u);
-}
-
-static void wFetch(FICL_VM *pVM)
-{
- UNS16 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pw = (UNS16 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pw);
- return;
-}
-
-static void wStore(FICL_VM *pVM)
-{
- UNS16 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pw = (UNS16 *)stackPopPtr(pVM->pStack);
- *pw = (UNS16)(stackPop(pVM->pStack).u);
-}
-
-static void cFetch(FICL_VM *pVM)
-{
- UNS8 *pc;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pc = (UNS8 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pc);
- return;
-}
-
-static void cStore(FICL_VM *pVM)
-{
- UNS8 *pc;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pc = (UNS8 *)stackPopPtr(pVM->pStack);
- *pc = (UNS8)(stackPop(pVM->pStack).u);
-}
-
-
-/**************************************************************************
- 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, *(int *)(pVM->ip));
- return;
-}
-
-
-/**************************************************************************
- 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 branch0(FICL_VM *pVM)
-{
- FICL_UNS flag;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- flag = stackPopUNS(pVM->pStack);
-
- if (flag)
- { /* fall through */
- vmBranchRelative(pVM, 1);
- }
- else
- { /* take branch (to else/endif/begin) */
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-/**************************************************************************
- 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 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
-** 3) Patch the "if" branch to point to the current compile address.
-** 4) Push the "else" patch address. ("endif" patches this to jump past
-** the "else" code.
-**************************************************************************/
-
-static void elseCoIm(FICL_VM *pVM)
-{
- CELL *patchAddr;
- FICL_INT offset;
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- /* (1) compile branch runtime */
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
- matchControlTag(pVM, origTag);
- patchAddr =
- (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
- markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
- dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
- offset = dp->here - patchAddr;
- *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
-
- return;
-}
-
-
-/**************************************************************************
- e n d i f C o I m
-** IMMEDIATE COMPILE-ONLY
-**************************************************************************/
-
-static void endifCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- resolveForwardBranch(dp, pVM, origTag);
- return;
-}
-
-
-/**************************************************************************
- 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)
-** calculates hashcode of specified string and leaves it on the stack
-**************************************************************************/
-
-static void hash(FICL_VM *pVM)
-{
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- PUSHUNS(hashHashCode(si));
- return;
-}
-
-
-/**************************************************************************
- i n t e r p r e t
-** This is the "user interface" of a Forth. It does the following:
-** while there are words in the VM's Text Input Buffer
-** Copy next word into the pad (vmGetWord)
-** Attempt to find the word in the dictionary (dictLookup)
-** If successful, execute the word.
-** Otherwise, attempt to convert the word to a number (isNumber)
-** If successful, push the number onto the parameter stack.
-** Otherwise, print an error message and exit loop...
-** End Loop
-**
-** From the standard, section 3.4
-** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
-** repeat the following steps until either the parse area is empty or an
-** ambiguous condition exists:
-** a) Skip leading spaces and parse a name (see 3.4.1);
-**************************************************************************/
-
-static void interpret(FICL_VM *pVM)
-{
- STRINGINFO si;
- int i;
- FICL_SYSTEM *pSys;
-
- assert(pVM);
-
- pSys = pVM->pSys;
- si = vmGetWord0(pVM);
-
- /*
- ** Get next word...if out of text, we're done.
- */
- if (si.count == 0)
- {
- vmThrow(pVM, VM_OUTOFTEXT);
- }
-
- /*
- ** Attempt to find the incoming token in the dictionary. If that fails...
- ** run the parse chain against the incoming token until somebody eats it.
- ** Otherwise emit an error message and give up.
- ** Although ficlParseWord could be part of the parse list, I've hard coded it
- ** in for robustness. ficlInitSystem adds the other default steps to the list.
- */
- if (ficlParseWord(pVM, si))
- return;
-
- for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
- {
- FICL_WORD *pFW = pSys->parseList[i];
-
- if (pFW == NULL)
- break;
-
- if (pFW->code == parseStepParen)
- {
- FICL_PARSE_STEP pStep;
- pStep = (FICL_PARSE_STEP)(pFW->param->fn);
- if ((*pStep)(pVM, si))
- return;
- }
- else
- {
- stackPushPtr(pVM->pStack, SI_PTR(si));
- stackPushUNS(pVM->pStack, SI_COUNT(si));
- ficlExecXT(pVM, pFW);
- if (stackPopINT(pVM->pStack))
- return;
- }
- }
-
- i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
-
- return; /* back to inner interpreter */
-}
-
-
-/**************************************************************************
- f i c l P a r s e W o r d
-** From the standard, section 3.4
-** b) Search the dictionary name space (see 3.4.2). If a definition name
-** matching the string is found:
-** 1.if interpreting, perform the interpretation semantics of the definition
-** (see 3.4.3.2), and continue at a);
-** 2.if compiling, perform the compilation semantics of the definition
-** (see 3.4.3.3), and continue at a).
-**
-** c) If a definition name matching the string is not found, attempt to
-** convert the string to a number (see 3.4.1.3). If successful:
-** 1.if interpreting, place the number on the data stack, and continue at a);
-** 2.if compiling, compile code that when executed will place the number on
-** the stack (see 6.1.1780 LITERAL), and continue at a);
-**
-** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
-**
-** (jws 4/01) Modified to be a FICL_PARSE_STEP
-**************************************************************************/
-static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *tempFW;
-
-#if FICL_ROBUST
- dictCheck(dp, pVM, 0);
- vmCheckStack(pVM, 0, 0);
-#endif
-
-#if FICL_WANT_LOCALS
- if (pVM->pSys->nLocals > 0)
- {
- tempFW = ficlLookupLoc(pVM->pSys, si);
- }
- else
-#endif
- tempFW = dictLookup(dp, si);
-
- if (pVM->state == INTERPRET)
- {
- if (tempFW != NULL)
- {
- if (wordIsCompileOnly(tempFW))
- {
- vmThrowErr(pVM, "Error: Compile only!");
- }
-
- vmExecute(pVM, tempFW);
- return FICL_TRUE;
- }
- }
-
- else /* (pVM->state == COMPILE) */
- {
- if (tempFW != NULL)
- {
- if (wordIsImmediate(tempFW))
- {
- vmExecute(pVM, tempFW);
- }
- else
- {
- dictAppendCell(dp, LVALUEtoCELL(tempFW));
- }
- return FICL_TRUE;
- }
- }
-
- return FICL_FALSE;
-}
-
-
-/*
-** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
-** INTERPRET)
-*/
-static void lookup(FICL_VM *pVM)
-{
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
- return;
-}
-
-
-/**************************************************************************
- p a r e n P a r s e S t e p
-** (parse-step) ( c-addr u -- flag )
-** runtime for a precompiled parse step - pop a counted string off the
-** stack, run the parse step against it, and push the result flag (FICL_TRUE
-** if success, FICL_FALSE otherwise).
-**************************************************************************/
-
-void parseStepParen(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW = pVM->runningWord;
- FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
-
- SI_SETLEN(si, stackPopINT(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
-
- PUSHINT((*pStep)(pVM, si));
-
- return;
-}
-
-
-static void addParseStep(FICL_VM *pVM)
-{
- FICL_WORD *pStep;
- FICL_DICT *pd = vmGetDict(pVM);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
- if ((pStep != NULL) && isAFiclWord(pd, pStep))
- ficlAddParseStep(pVM->pSys, pStep);
- return;
-}
-
-
-/**************************************************************************
- l i t e r a l P a r e n
-**
-** This is the runtime for (literal). It assumes that it is part of a colon
-** definition, and that the next CELL contains a value to be pushed on the
-** parameter stack at runtime. This code is compiled by "literal".
-**
-**************************************************************************/
-
-static void literalParen(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- PUSHINT(*(FICL_INT *)(pVM->ip));
- vmBranchRelative(pVM, 1);
- return;
-}
-
-static void twoLitParen(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- PUSHINT(*((FICL_INT *)(pVM->ip)+1));
- PUSHINT(*(FICL_INT *)(pVM->ip));
- vmBranchRelative(pVM, 2);
- return;
-}
-
-
-/**************************************************************************
- l i t e r a l I m
-**
-** IMMEDIATE code for "literal". This function gets a value from the stack
-** and compiles it into the dictionary preceded by the code for "(literal)".
-** IMMEDIATE
-**************************************************************************/
-
-static void literalIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pLitParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
- dictAppendCell(dp, stackPop(pVM->pStack));
-
- return;
-}
-
-
-static void twoLiteralIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pTwoLitParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
- dictAppendCell(dp, stackPop(pVM->pStack));
- dictAppendCell(dp, stackPop(pVM->pStack));
-
- return;
-}
-
-/**************************************************************************
- l o g i c a n d c o m p a r i s o n s
-**
-**************************************************************************/
-
-static void zeroEquals(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void zeroLess(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void zeroGreater(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void isEqual(FICL_VM *pVM)
-{
- CELL x, y;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i == y.i));
- return;
-}
-
-static void isLess(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- y = stackPop(pVM->pStack);
- x = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i < y.i));
- return;
-}
-
-static void uIsLess(FICL_VM *pVM)
-{
- FICL_UNS u1, u2;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- u2 = stackPopUNS(pVM->pStack);
- u1 = stackPopUNS(pVM->pStack);
- PUSHINT(FICL_BOOL(u1 < u2));
- return;
-}
-
-static void isGreater(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- y = stackPop(pVM->pStack);
- x = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i > y.i));
- return;
-}
-
-static void bitwiseAnd(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i & y.i);
- return;
-}
-
-static void bitwiseOr(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i | y.i);
- return;
-}
-
-static void bitwiseXor(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i ^ y.i);
- return;
-}
-
-static void bitwiseNot(FICL_VM *pVM)
-{
- CELL x;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- x = stackPop(pVM->pStack);
- PUSHINT(~x.i);
- return;
-}
-
-
-/**************************************************************************
- D o / L o o p
-** do -- IMMEDIATE COMPILE ONLY
-** Compiles code to initialize a loop: compile (do),
-** allot space to hold the "leave" address, push a branch
-** target address for the loop.
-** (do) -- runtime for "do"
-** pops index and limit from the p stack and moves them
-** to the r stack, then skips to the loop body.
-** loop -- IMMEDIATE COMPILE ONLY
-** +loop
-** Compiles code for the test part of a loop:
-** compile (loop), resolve forward branch from "do", and
-** copy "here" address to the "leave" address allotted by "do"
-** i,j,k -- COMPILE ONLY
-** Runtime: Push loop indices on param stack (i is innermost loop...)
-** Note: each loop has three values on the return stack:
-** ( R: leave limit index )
-** "leave" is the absolute address of the next cell after the loop
-** limit and index are the loop control variables.
-** leave -- COMPILE ONLY
-** Runtime: pop the loop control variables, then pop the
-** "leave" address and jump (absolute) there.
-**************************************************************************/
-
-static void doCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pDoParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
- /*
- ** Allot space for a pointer to the end
- ** of the loop - "leave" uses this...
- */
- markBranch(dp, pVM, leaveTag);
- dictAppendUNS(dp, 0);
- /*
- ** Mark location of head of loop...
- */
- markBranch(dp, pVM, doTag);
-
- return;
-}
-
-
-static void doParen(FICL_VM *pVM)
-{
- CELL index, limit;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- index = stackPop(pVM->pStack);
- limit = stackPop(pVM->pStack);
-
- /* copy "leave" target addr to stack */
- stackPushPtr(pVM->rStack, *(pVM->ip++));
- stackPush(pVM->rStack, limit);
- stackPush(pVM->rStack, index);
-
- return;
-}
-
-
-static void qDoCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pQDoParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
- /*
- ** Allot space for a pointer to the end
- ** of the loop - "leave" uses this...
- */
- markBranch(dp, pVM, leaveTag);
- dictAppendUNS(dp, 0);
- /*
- ** Mark location of head of loop...
- */
- markBranch(dp, pVM, doTag);
-
- return;
-}
-
-
-static void qDoParen(FICL_VM *pVM)
-{
- CELL index, limit;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- index = stackPop(pVM->pStack);
- limit = stackPop(pVM->pStack);
-
- /* copy "leave" target addr to stack */
- stackPushPtr(pVM->rStack, *(pVM->ip++));
-
- if (limit.u == index.u)
- {
- vmPopIP(pVM);
- }
- else
- {
- stackPush(pVM->rStack, limit);
- stackPush(pVM->rStack, index);
- }
-
- return;
-}
-
-
-/*
-** Runtime code to break out of a do..loop construct
-** Drop the loop control variables; the branch address
-** past "loop" is next on the return stack.
-*/
-static void leaveCo(FICL_VM *pVM)
-{
- /* almost unloop */
- stackDrop(pVM->rStack, 2);
- /* exit */
- vmPopIP(pVM);
- return;
-}
-
-
-static void unloopCo(FICL_VM *pVM)
-{
- stackDrop(pVM->rStack, 3);
- return;
-}
-
-
-static void loopCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pLoopParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
- resolveBackBranch(dp, pVM, doTag);
- resolveAbsBranch(dp, pVM, leaveTag);
- return;
-}
-
-
-static void plusLoopCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pPLoopParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
- resolveBackBranch(dp, pVM, doTag);
- resolveAbsBranch(dp, pVM, leaveTag);
- return;
-}
-
-
-static void loopParen(FICL_VM *pVM)
-{
- FICL_INT index = stackGetTop(pVM->rStack).i;
- FICL_INT limit = stackFetch(pVM->rStack, 1).i;
-
- index++;
-
- if (index >= limit)
- {
- stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
- vmBranchRelative(pVM, 1); /* fall through the loop */
- }
- else
- { /* update index, branch to loop head */
- stackSetTop(pVM->rStack, LVALUEtoCELL(index));
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-static void plusLoopParen(FICL_VM *pVM)
-{
- FICL_INT index,limit,increment;
- int flag;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- index = stackGetTop(pVM->rStack).i;
- limit = stackFetch(pVM->rStack, 1).i;
- increment = POP().i;
-
- index += increment;
-
- if (increment < 0)
- flag = (index < limit);
- else
- flag = (index >= limit);
-
- if (flag)
- {
- stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
- vmBranchRelative(pVM, 1); /* fall through the loop */
- }
- else
- { /* update index, branch to loop head */
- stackSetTop(pVM->rStack, LVALUEtoCELL(index));
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-static void loopICo(FICL_VM *pVM)
-{
- CELL index = stackGetTop(pVM->rStack);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-static void loopJCo(FICL_VM *pVM)
-{
- CELL index = stackFetch(pVM->rStack, 3);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-static void loopKCo(FICL_VM *pVM)
-{
- CELL index = stackFetch(pVM->rStack, 6);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-/**************************************************************************
- r e t u r n s t a c k
-**
-**************************************************************************/
-static void toRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- stackPush(pVM->rStack, POP());
-}
-
-static void fromRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- PUSH(stackPop(pVM->rStack));
-}
-
-static void fetchRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- PUSH(stackGetTop(pVM->rStack));
-}
-
-static void twoToR(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- stackRoll(pVM->pStack, 1);
- stackPush(pVM->rStack, stackPop(pVM->pStack));
- stackPush(pVM->rStack, stackPop(pVM->pStack));
- return;
-}
-
-static void twoRFrom(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, stackPop(pVM->rStack));
- stackPush(pVM->pStack, stackPop(pVM->rStack));
- stackRoll(pVM->pStack, 1);
- return;
-}
-
-static void twoRFetch(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
- stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
- return;
-}
-
-
-/**************************************************************************
- v a r i a b l e
-**
-**************************************************************************/
-
-static void variableParen(FICL_VM *pVM)
-{
- FICL_WORD *fw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- fw = pVM->runningWord;
- PUSHPTR(fw->param);
-}
-
-
-static void variable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- return;
-}
-
-
-static void twoVariable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
- dictAllotCells(dp, 2);
- return;
-}
-
-
-/**************************************************************************
- b a s e & f r i e n d s
-**
-**************************************************************************/
-
-static void base(FICL_VM *pVM)
-{
- CELL *pBase;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pBase = (CELL *)(&pVM->base);
- stackPush(pVM->pStack, LVALUEtoCELL(pBase));
- return;
-}
-
-
-static void decimal(FICL_VM *pVM)
-{
- pVM->base = 10;
- return;
-}
-
-
-static void hex(FICL_VM *pVM)
-{
- pVM->base = 16;
- return;
-}
-
-
-/**************************************************************************
- a l l o t & f r i e n d s
-**
-**************************************************************************/
-
-static void allot(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- i = POPINT();
-
-#if FICL_ROBUST
- dictCheck(dp, pVM, i);
-#endif
-
- dictAllot(dp, i);
- return;
-}
-
-
-static void here(FICL_VM *pVM)
-{
- FICL_DICT *dp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- dp = vmGetDict(pVM);
- PUSHPTR(dp->here);
- return;
-}
-
-static void comma(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- c = POP();
- dictAppendCell(dp, c);
- return;
-}
-
-static void cComma(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- char c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- c = (char)POPINT();
- dictAppendChar(dp, c);
- return;
-}
-
-static void cells(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- i = POPINT();
- PUSHINT(i * (FICL_INT)sizeof (CELL));
- return;
-}
-
-static void cellPlus(FICL_VM *pVM)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- cp = POPPTR();
- PUSHPTR(cp + sizeof (CELL));
- return;
-}
-
-
-
-/**************************************************************************
- t i c k
-** tick CORE ( "<spaces>name" -- xt )
-** Skip leading space delimiters. Parse name delimited by a space. Find
-** name and return xt, the execution token for name. An ambiguous condition
-** exists if name is not found.
-**************************************************************************/
-void ficlTick(FICL_VM *pVM)
-{
- FICL_WORD *pFW = NULL;
- STRINGINFO si = vmGetWord(pVM);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pFW = dictLookup(vmGetDict(pVM), si);
- if (!pFW)
- {
- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
- PUSHPTR(pFW);
- return;
-}
-
-
-static void bracketTickCoIm(FICL_VM *pVM)
-{
- ficlTick(pVM);
- literalIm(pVM);
-
- return;
-}
-
-
-/**************************************************************************
- p o s t p o n e
-** Lookup the next word in the input stream and compile code to
-** insert it into definitions created by the resulting word
-** (defers compilation, even of immediate words)
-**************************************************************************/
-
-static void postponeCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
- FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
- assert(pComma);
-
- ficlTick(pVM);
- pFW = stackGetTop(pVM->pStack).p;
- if (wordIsImmediate(pFW))
- {
- dictAppendCell(dp, stackPop(pVM->pStack));
- }
- else
- {
- literalIm(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pComma));
- }
-
- return;
-}
-
-
-
-/**************************************************************************
- e x e c u t e
-** Pop an execution token (pointer to a word) off the stack and
-** run it
-**************************************************************************/
-
-static void execute(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- pFW = stackPopPtr(pVM->pStack);
- vmExecute(pVM, pFW);
-
- return;
-}
-
-
-/**************************************************************************
- i m m e d i a t e
-** Make the most recently compiled word IMMEDIATE -- it executes even
-** in compile state (most often used for control compiling words
-** such as IF, THEN, etc)
-**************************************************************************/
-
-static void immediate(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetImmediate(vmGetDict(pVM));
- return;
-}
-
-
-static void compileOnly(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
- return;
-}
-
-
-static void setObjectFlag(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
- return;
-}
-
-static void isObject(FICL_VM *pVM)
-{
- int flag;
- FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
-
- flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
- stackPushINT(pVM->pStack, flag);
- return;
-}
-
-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
-** Compile stringLit, then copy the bytes of the string from the TIB
-** to the dictionary. Backpatch the count byte and align the dictionary.
-**
-** stringlit: Fetch the count from the dictionary, then push the address
-** and count on the stack. Finally, update ip to point to the first
-** aligned address after the string text.
-**************************************************************************/
-
-static void stringLit(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- FICL_COUNT count;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
-
- sp = (FICL_STRING *)(pVM->ip);
- count = sp->count;
- cp = sp->text;
- PUSHPTR(cp);
- PUSHUNS(count);
- cp += count + 1;
- cp = alignPtr(cp);
- pVM->ip = (IPTYPE)(void *)cp;
-}
-
-static void dotQuoteCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
- assert(pType);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
- dictAlign(dp);
- dictAppendCell(dp, LVALUEtoCELL(pType));
- return;
-}
-
-
-static void dotParen(FICL_VM *pVM)
-{
- char *pSrc = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- char *pDest = pVM->pad;
- char ch;
-
- /*
- ** Note: the standard does not want leading spaces skipped (apparently)
- */
- for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
- *pDest++ = ch;
-
- *pDest = '\0';
- if ((pEnd != pSrc) && (ch == ')'))
- pSrc++;
-
- vmTextOut(pVM, pVM->pad, 0);
- vmUpdateTib(pVM, pSrc);
-
- return;
-}
-
-
-/**************************************************************************
- s l i t e r a l
-** STRING
-** Interpretation: Interpretation semantics for this word are undefined.
-** Compilation: ( c-addr1 u -- )
-** Append the run-time semantics given below to the current definition.
-** Run-time: ( -- c-addr2 u )
-** Return c-addr2 u describing a string consisting of the characters
-** specified by c-addr1 u during compilation. A program shall not alter
-** the returned string.
-**************************************************************************/
-static void sLiteralCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- char *cp, *cpDest;
- FICL_UNS u;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
-
- dp = vmGetDict(pVM);
- u = POPUNS();
- cp = POPPTR();
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- cpDest = (char *) dp->here;
- *cpDest++ = (char) u;
-
- for (; u > 0; --u)
- {
- *cpDest++ = *cp++;
- }
-
- *cpDest++ = 0;
- dp->here = PTRtoCELL alignPtr(cpDest);
- return;
-}
-
-
-/**************************************************************************
- s t a t e
-** Return the address of the VM's state member (must be sized the
-** same as a CELL for this reason)
-**************************************************************************/
-static void state(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- PUSHPTR(&pVM->state);
- return;
-}
-
-
-/**************************************************************************
- c r e a t e . . . d o e s >
-** Make a new word in the dictionary with the run-time effect of
-** a variable (push my address), but with extra space allotted
-** for use by does> .
-**************************************************************************/
-
-static void createParen(FICL_VM *pVM)
-{
- CELL *pCell;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pCell = pVM->runningWord->param;
- PUSHPTR(pCell+1);
- return;
-}
-
-
-static void create(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, createParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- return;
-}
-
-
-static void doDoes(FICL_VM *pVM)
-{
- CELL *pCell;
- IPTYPE tempIP;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pCell = pVM->runningWord->param;
- tempIP = (IPTYPE)((*pCell).p);
- PUSHPTR(pCell+1);
- vmPushIP(pVM, tempIP);
- return;
-}
-
-
-static void doesParen(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- dp->smudge->code = doDoes;
- dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
- vmPopIP(pVM);
- return;
-}
-
-
-static void doesCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-#if FICL_WANT_LOCALS
- assert(pVM->pSys->pUnLinkParen);
- if (pVM->pSys->nLocals > 0)
- {
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
-
- pVM->pSys->nLocals = 0;
-#endif
- IGNORE(pVM);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
- return;
-}
-
-
-/**************************************************************************
- t o b o d y
-** to-body CORE ( xt -- a-addr )
-** a-addr is the data-field address corresponding to xt. An ambiguous
-** condition exists if xt is not for a word defined via CREATE.
-**************************************************************************/
-static void toBody(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-/*#$-GUY CHANGE: Added robustness.-$#*/
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- pFW = POPPTR();
- PUSHPTR(pFW->param + 1);
- return;
-}
-
-
-/*
-** from-body ficl ( a-addr -- xt )
-** Reverse effect of >body
-*/
-static void fromBody(FICL_VM *pVM)
-{
- char *ptr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- ptr = (char *)POPPTR() - sizeof (FICL_WORD);
- PUSHPTR(ptr);
- return;
-}
-
-
-/*
-** >name ficl ( xt -- c-addr u )
-** Push the address and length of a word's name given its address
-** xt.
-*/
-static void toName(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
-
- pFW = POPPTR();
- PUSHPTR(pFW->name);
- PUSHUNS(pFW->nName);
- return;
-}
-
-
-static void getLastWord(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_WORD *wp = pDict->smudge;
- assert(wp);
- vmPush(pVM, LVALUEtoCELL(wp));
- return;
-}
-
-
-/**************************************************************************
- l b r a c k e t e t c
-**
-**************************************************************************/
-
-static void lbracketCoIm(FICL_VM *pVM)
-{
- pVM->state = INTERPRET;
- return;
-}
-
-
-static void rbracket(FICL_VM *pVM)
-{
- pVM->state = COMPILE;
- return;
-}
-
-
-/**************************************************************************
- p i c t u r e d n u m e r i c w o r d s
-**
-** less-number-sign CORE ( -- )
-** Initialize the pictured numeric output conversion process.
-** (clear the pad)
-**************************************************************************/
-static void lessNumberSign(FICL_VM *pVM)
-{
- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- sp->count = 0;
- return;
-}
-
-/*
-** number-sign CORE ( ud1 -- ud2 )
-** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
-** n. (n is the least-significant digit of ud1.) Convert n to external form
-** and add the resulting character to the beginning of the pictured numeric
-** output string. An ambiguous condition exists if # executes outside of a
-** <# #> delimited number conversion.
-*/
-static void numberSign(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- DPUNS u;
- UNS16 rem;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- u = u64Pop(pVM->pStack);
- rem = m64UMod(&u, (UNS16)(pVM->base));
- sp->text[sp->count++] = digit_to_char(rem);
- u64Push(pVM->pStack, u);
- return;
-}
-
-/*
-** number-sign-greater CORE ( xd -- c-addr u )
-** Drop xd. Make the pictured numeric output string available as a character
-** string. c-addr and u specify the resulting character string. A program
-** may replace characters within the string.
-*/
-static void numberSignGreater(FICL_VM *pVM)
-{
- FICL_STRING *sp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- sp->text[sp->count] = 0;
- strrev(sp->text);
- DROP(2);
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- return;
-}
-
-/*
-** number-sign-s CORE ( ud1 -- ud2 )
-** Convert one digit of ud1 according to the rule for #. Continue conversion
-** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
-** #S executes outside of a <# #> delimited number conversion.
-** TO DO: presently does not use ud1 hi cell - use it!
-*/
-static void numberSignS(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- DPUNS u;
- UNS16 rem;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- u = u64Pop(pVM->pStack);
-
- do
- {
- rem = m64UMod(&u, (UNS16)(pVM->base));
- sp->text[sp->count++] = digit_to_char(rem);
- }
- while (u.hi || u.lo);
-
- u64Push(pVM->pStack, u);
- return;
-}
-
-/*
-** HOLD CORE ( char -- )
-** Add char to the beginning of the pictured numeric output string. An ambiguous
-** condition exists if HOLD executes outside of a <# #> delimited number conversion.
-*/
-static void hold(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- i = POPINT();
- sp->text[sp->count++] = (char) i;
- return;
-}
-
-/*
-** SIGN CORE ( n -- )
-** If n is negative, add a minus sign to the beginning of the pictured
-** numeric output string. An ambiguous condition exists if SIGN
-** executes outside of a <# #> delimited number conversion.
-*/
-static void sign(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- i = POPINT();
- if (i < 0)
- sp->text[sp->count++] = '-';
- return;
-}
-
-
-/**************************************************************************
- t o N u m b e r
-** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
-** ud2 is the unsigned result of converting the characters within the
-** string specified by c-addr1 u1 into digits, using the number in BASE,
-** and adding each into ud1 after multiplying ud1 by the number in BASE.
-** Conversion continues left-to-right until a character that is not
-** convertible, including any + or -, is encountered or the string is
-** entirely converted. c-addr2 is the location of the first unconverted
-** character or the first character past the end of the string if the string
-** was entirely converted. u2 is the number of unconverted characters in the
-** string. An ambiguous condition exists if ud2 overflows during the
-** conversion.
-**************************************************************************/
-static void toNumber(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
- DPUNS accum;
- FICL_UNS base = pVM->base;
- FICL_UNS ch;
- FICL_UNS digit;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,4,4);
-#endif
-
- count = POPUNS();
- cp = (char *)POPPTR();
- accum = u64Pop(pVM->pStack);
-
- for (ch = *cp; count > 0; ch = *++cp, count--)
- {
- if (ch < '0')
- break;
-
- digit = ch - '0';
-
- if (digit > 9)
- digit = tolower(ch) - 'a' + 10;
- /*
- ** Note: following test also catches chars between 9 and a
- ** because 'digit' is unsigned!
- */
- if (digit >= base)
- break;
-
- accum = m64Mac(accum, base, digit);
- }
-
- u64Push(pVM->pStack, accum);
- PUSHPTR(cp);
- PUSHUNS(count);
-
- return;
-}
-
-
-
-/**************************************************************************
- q u i t & a b o r t
-** quit CORE ( -- ) ( R: i*x -- )
-** Empty the return stack, store zero in SOURCE-ID if it is present, make
-** the user input device the input source, and enter interpretation state.
-** Do not display a message. Repeat the following:
-**
-** Accept a line from the input source into the input buffer, set >IN to
-** zero, and interpret.
-** Display the implementation-defined system prompt if in
-** interpretation state, all processing has been completed, and no
-** ambiguous condition exists.
-**************************************************************************/
-
-static void quit(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_QUIT);
- return;
-}
-
-
-static void ficlAbort(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_ABORT);
- return;
-}
-
-
-/**************************************************************************
- a c c e p t
-** accept CORE ( c-addr +n1 -- +n2 )
-** Receive a string of at most +n1 characters. An ambiguous condition
-** exists if +n1 is zero or greater than 32,767. Display graphic characters
-** as they are received. A program that depends on the presence or absence
-** of non-graphic characters in the string has an environmental dependency.
-** The editing functions, if any, that the system performs in order to
-** construct the string are implementation-defined.
-**
-** (Although the standard text doesn't say so, I assume that the intent
-** of 'accept' is to store the string at the address specified on
-** the stack.)
-** Implementation: if there's more text in the TIB, use it. Otherwise
-** throw out for more text. Copy characters up to the max count into the
-** address given, and return the number of actual characters copied.
-**
-** Note (sobral) this may not be the behavior you'd expect if you're
-** trying to get user input at load time!
-**************************************************************************/
-static void accept(FICL_VM *pVM)
-{
- FICL_UNS count, len;
- char *cp;
- char *pBuf, *pEnd;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- pBuf = vmGetInBuf(pVM);
- pEnd = vmGetInBufEnd(pVM);
- len = pEnd - pBuf;
- if (len == 0)
- vmThrow(pVM, VM_RESTART);
-
- /*
- ** Now we have something in the text buffer - use it
- */
- count = stackPopINT(pVM->pStack);
- cp = stackPopPtr(pVM->pStack);
-
- len = (count < len) ? count : len;
- strncpy(cp, vmGetInBuf(pVM), len);
- pBuf += len;
- vmUpdateTib(pVM, pBuf);
- PUSHINT(len);
-
- return;
-}
-
-
-/**************************************************************************
- a l i g n
-** 6.1.0705 ALIGN CORE ( -- )
-** If the data-space pointer is not aligned, reserve enough space to
-** align it.
-**************************************************************************/
-static void align(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- IGNORE(pVM);
- dictAlign(dp);
- return;
-}
-
-
-/**************************************************************************
- a l i g n e d
-**
-**************************************************************************/
-static void aligned(FICL_VM *pVM)
-{
- void *addr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- addr = POPPTR();
- PUSHPTR(alignPtr(addr));
- return;
-}
-
-
-/**************************************************************************
- b e g i n & f r i e n d s
-** Indefinite loop control structures
-** A.6.1.0760 BEGIN
-** Typical use:
-** : X ... BEGIN ... test UNTIL ;
-** or
-** : X ... BEGIN ... test WHILE ... REPEAT ;
-**************************************************************************/
-static void beginCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- markBranch(dp, pVM, destTag);
- return;
-}
-
-static void untilCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranch0);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
- resolveBackBranch(dp, pVM, destTag);
- return;
-}
-
-static void whileCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranch0);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranch0));
- markBranch(dp, pVM, origTag);
- twoSwap(pVM);
- dictAppendUNS(dp, 1);
- return;
-}
-
-static void repeatCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
-
- /* expect "begin" branch marker */
- resolveBackBranch(dp, pVM, destTag);
- /* expect "while" branch marker */
- resolveForwardBranch(dp, pVM, origTag);
- return;
-}
-
-
-static void againCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
-
- /* expect "begin" branch marker */
- resolveBackBranch(dp, pVM, destTag);
- return;
-}
-
-
-/**************************************************************************
- c h a r & f r i e n d s
-** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
-** Skip leading space delimiters. Parse name delimited by a space.
-** Put the value of its first character onto the stack.
-**
-** bracket-char CORE
-** Interpretation: Interpretation semantics for this word are undefined.
-** Compilation: ( "<spaces>name" -- )
-** Skip leading space delimiters. Parse name delimited by a space.
-** Append the run-time semantics given below to the current definition.
-** Run-time: ( -- char )
-** Place char, the value of the first character of name, on the stack.
-**************************************************************************/
-static void ficlChar(FICL_VM *pVM)
-{
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,1);
-#endif
-
- si = vmGetWord(pVM);
- PUSHUNS((FICL_UNS)(si.cp[0]));
- return;
-}
-
-static void charCoIm(FICL_VM *pVM)
-{
- ficlChar(pVM);
- literalIm(pVM);
- return;
-}
-
-/**************************************************************************
- c h a r P l u s
-** char-plus CORE ( c-addr1 -- c-addr2 )
-** Add the size in address units of a character to c-addr1, giving c-addr2.
-**************************************************************************/
-static void charPlus(FICL_VM *pVM)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- cp = POPPTR();
- PUSHPTR(cp + 1);
- return;
-}
-
-/**************************************************************************
- c h a r s
-** chars CORE ( n1 -- n2 )
-** n2 is the size in address units of n1 characters.
-** For most processors, this function can be a no-op. To guarantee
-** portability, we'll multiply by sizeof (char).
-**************************************************************************/
-#if defined (_M_IX86)
-#pragma warning(disable: 4127)
-#endif
-static void ficlChars(FICL_VM *pVM)
-{
- if (sizeof (char) > 1)
- {
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
- i = POPINT();
- PUSHINT(i * sizeof (char));
- }
- /* otherwise no-op! */
- return;
-}
-#if defined (_M_IX86)
-#pragma warning(default: 4127)
-#endif
-
-
-/**************************************************************************
- c o u n t
-** COUNT CORE ( c-addr1 -- c-addr2 u )
-** Return the character string specification for the counted string stored
-** at c-addr1. c-addr2 is the address of the first character after c-addr1.
-** u is the contents of the character at c-addr1, which is the length in
-** characters of the string at c-addr2.
-**************************************************************************/
-static void count(FICL_VM *pVM)
-{
- FICL_STRING *sp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- sp = POPPTR();
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- return;
-}
-
-/**************************************************************************
- e n v i r o n m e n t ?
-** environment-query CORE ( c-addr u -- false | i*x true )
-** c-addr is the address of a character string and u is the string's
-** character count. u may have a value in the range from zero to an
-** implementation-defined maximum which shall not be less than 31. The
-** character string should contain a keyword from 3.2.6 Environmental
-** queries or the optional word sets to be checked for correspondence
-** with an attribute of the present environment. If the system treats the
-** attribute as unknown, the returned flag is false; otherwise, the flag
-** is true and the i*x returned is of the type specified in the table for
-** the attribute queried.
-**************************************************************************/
-static void environmentQ(FICL_VM *pVM)
-{
- FICL_DICT *envp;
- FICL_WORD *pFW;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- envp = pVM->pSys->envp;
- si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
- si.cp = stackPopPtr(pVM->pStack);
-
- pFW = dictLookup(envp, si);
-
- if (pFW != NULL)
- {
- vmExecute(pVM, pFW);
- PUSHINT(FICL_TRUE);
- }
- else
- {
- PUSHINT(FICL_FALSE);
- }
- return;
-}
-
-/**************************************************************************
- e v a l u a t e
-** EVALUATE CORE ( i*x c-addr u -- j*x )
-** Save the current input source specification. Store minus-one (-1) in
-** SOURCE-ID if it is present. Make the string described by c-addr and u
-** both the input source and input buffer, set >IN to zero, and interpret.
-** When the parse area is empty, restore the prior input source
-** specification. Other stack effects are due to the words EVALUATEd.
-**
-**************************************************************************/
-static void evaluate(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
- CELL id;
- int result;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,0);
-#endif
-
- count = POPUNS();
- cp = POPPTR();
-
- IGNORE(count);
- id = pVM->sourceID;
- pVM->sourceID.i = -1;
- result = ficlExecC(pVM, cp, count);
- pVM->sourceID = id;
- if (result != VM_OUTOFTEXT)
- vmThrow(pVM, result);
-
- return;
-}
-
-
-/**************************************************************************
- s t r i n g q u o t e
-** Interpreting: get string delimited by a quote from the input stream,
-** copy to a scratch area, and put its count and address on the stack.
-** Compiling: compile code to push the address and count of a string
-** literal, compile the string from the input stream, and align the dict
-** pointer.
-**************************************************************************/
-static void stringQuoteIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- if (pVM->state == INTERPRET)
- {
- FICL_STRING *sp = (FICL_STRING *) dp->here;
- vmGetString(pVM, sp, '\"');
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- }
- else /* COMPILE state */
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
- dictAlign(dp);
- }
-
- return;
-}
-
-
-/**************************************************************************
- t y p e
-** Pop count and char address from stack and print the designated string.
-**************************************************************************/
-static void type(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
-
- count = POPUNS();
- cp = POPPTR();
-
- /*
- ** Since we don't have an output primitive for a counted string
- ** (oops), make sure the string is null terminated. If not, copy
- ** and terminate it.
- */
- if (cp[count] != 0)
- {
- char *pDest = (char *)vmGetDict(pVM)->here;
- if (cp != pDest)
- strncpy(pDest, cp, count);
-
- pDest[count] = '\0';
- cp = pDest;
- }
-
- vmTextOut(pVM, cp, 0);
- return;
-}
-
-/**************************************************************************
- w o r d
-** word CORE ( char "<chars>ccc<char>" -- c-addr )
-** Skip leading delimiters. Parse characters ccc delimited by char. An
-** ambiguous condition exists if the length of the parsed string is greater
-** than the implementation-defined length of a counted string.
-**
-** c-addr is the address of a transient region containing the parsed word
-** as a counted string. If the parse area was empty or contained no
-** characters other than the delimiter, the resulting string has a zero
-** length. A space, not included in the length, follows the string. A
-** program may replace characters within the string.
-** NOTE! Ficl also NULL-terminates the dest string.
-**************************************************************************/
-static void ficlWord(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- char delim;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- sp = (FICL_STRING *)pVM->pad;
- delim = (char)POPINT();
- si = vmParseStringEx(pVM, delim, 1);
-
- if (SI_COUNT(si) > nPAD-1)
- SI_SETLEN(si, nPAD-1);
-
- sp->count = (FICL_COUNT)SI_COUNT(si);
- strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
- /*#$-GUY CHANGE: I added this.-$#*/
- sp->text[sp->count] = 0;
- strcat(sp->text, " ");
-
- PUSHPTR(sp);
- return;
-}
-
-
-/**************************************************************************
- p a r s e - w o r d
-** ficl PARSE-WORD ( <spaces>name -- c-addr u )
-** Skip leading spaces and parse name delimited by a space. c-addr is the
-** address within the input buffer and u is the length of the selected
-** string. If the parse area is empty, the resulting string has a zero length.
-**************************************************************************/
-static void parseNoCopy(FICL_VM *pVM)
-{
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,2);
-#endif
-
- si = vmGetWord0(pVM);
- PUSHPTR(SI_PTR(si));
- PUSHUNS(SI_COUNT(si));
- return;
-}
-
-
-/**************************************************************************
- p a r s e
-** CORE EXT ( char "ccc<char>" -- c-addr u )
-** Parse ccc delimited by the delimiter char.
-** c-addr is the address (within the input buffer) and u is the length of
-** the parsed string. If the parse area was empty, the resulting string has
-** a zero length.
-** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
-**************************************************************************/
-static void parse(FICL_VM *pVM)
-{
- STRINGINFO si;
- char delim;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- delim = (char)POPINT();
-
- si = vmParseStringEx(pVM, delim, 0);
- PUSHPTR(SI_PTR(si));
- PUSHUNS(SI_COUNT(si));
- return;
-}
-
-
-/**************************************************************************
- f i l l
-** CORE ( c-addr u char -- )
-** If u is greater than zero, store char in each of u consecutive
-** characters of memory beginning at c-addr.
-**************************************************************************/
-static void fill(FICL_VM *pVM)
-{
- char ch;
- FICL_UNS u;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,0);
-#endif
- ch = (char)POPINT();
- u = POPUNS();
- cp = (char *)POPPTR();
-
- while (u > 0)
- {
- *cp++ = ch;
- u--;
- }
- return;
-}
-
-
-/**************************************************************************
- 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 do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
-{
- FICL_WORD *pFW;
-
- pFW = dictLookup(vmGetDict(pVM), si);
- if (pFW)
- {
- PUSHPTR(pFW);
- PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
- }
- else
- {
- PUSHPTR(returnForFailure);
- PUSHUNS(0);
- }
- return;
-}
-
-
-
-/**************************************************************************
- 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.
-** Input and output stack arguments are signed. An ambiguous condition
-** exists if n1 is zero or if the quotient lies outside the range of a
-** single-cell signed integer.
-**************************************************************************/
-static void fmSlashMod(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,2);
-#endif
-
- n1 = POPINT();
- d1 = i64Pop(pVM->pStack);
- qr = m64FlooredDivI(d1, n1);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- s m S l a s h R e m
-** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
-** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
-** Input and output stack arguments are signed. An ambiguous condition
-** exists if n1 is zero or if the quotient lies outside the range of a
-** single-cell signed integer.
-**************************************************************************/
-static void smSlashRem(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,2);
-#endif
-
- n1 = POPINT();
- d1 = i64Pop(pVM->pStack);
- qr = m64SymmetricDivI(d1, n1);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-static void ficlMod(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n1 = POPINT();
- d1.lo = POPINT();
- i64Extend(d1);
- qr = m64SymmetricDivI(d1, n1);
- PUSHINT(qr.rem);
- return;
-}
-
-
-/**************************************************************************
- u m S l a s h M o d
-** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
-** Divide ud by u1, giving the quotient u3 and the remainder u2.
-** All values and arithmetic are unsigned. An ambiguous condition
-** exists if u1 is zero or if the quotient lies outside the range of a
-** single-cell unsigned integer.
-*************************************************************************/
-static void umSlashMod(FICL_VM *pVM)
-{
- DPUNS ud;
- FICL_UNS u1;
- UNSQR qr;
-
- u1 = stackPopUNS(pVM->pStack);
- ud = u64Pop(pVM->pStack);
- qr = ficlLongDiv(ud, u1);
- PUSHUNS(qr.rem);
- PUSHUNS(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- l s h i f t
-** l-shift CORE ( x1 u -- x2 )
-** Perform a logical left shift of u bit-places on x1, giving x2.
-** Put zeroes into the least significant bits vacated by the shift.
-** An ambiguous condition exists if u is greater than or equal to the
-** number of bits in a cell.
-**
-** r-shift CORE ( x1 u -- x2 )
-** Perform a logical right shift of u bit-places on x1, giving x2.
-** Put zeroes into the most significant bits vacated by the shift. An
-** ambiguous condition exists if u is greater than or equal to the
-** number of bits in a cell.
-**************************************************************************/
-static void lshift(FICL_VM *pVM)
-{
- FICL_UNS nBits;
- FICL_UNS x1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- nBits = POPUNS();
- x1 = POPUNS();
- PUSHUNS(x1 << nBits);
- return;
-}
-
-
-static void rshift(FICL_VM *pVM)
-{
- FICL_UNS nBits;
- FICL_UNS x1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- nBits = POPUNS();
- x1 = POPUNS();
-
- PUSHUNS(x1 >> nBits);
- return;
-}
-
-
-/**************************************************************************
- m S t a r
-** m-star CORE ( n1 n2 -- d )
-** d is the signed product of n1 times n2.
-**************************************************************************/
-static void mStar(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
- DPINT d;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,2);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- d = m64MulI(n1, n2);
- i64Push(pVM->pStack, d);
- return;
-}
-
-
-static void umStar(FICL_VM *pVM)
-{
- FICL_UNS u2;
- FICL_UNS u1;
- DPUNS ud;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,2);
-#endif
-
- u2 = POPUNS();
- u1 = POPUNS();
-
- ud = ficlLongMul(u1, u2);
- u64Push(pVM->pStack, ud);
- return;
-}
-
-
-/**************************************************************************
- m a x & m i n
-**
-**************************************************************************/
-static void ficlMax(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- PUSHINT((n1 > n2) ? n1 : n2);
- return;
-}
-
-static void ficlMin(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- PUSHINT((n1 < n2) ? n1 : n2);
- return;
-}
-
-
-/**************************************************************************
- m o v e
-** CORE ( addr1 addr2 u -- )
-** If u is greater than zero, copy the contents of u consecutive address
-** units at addr1 to the u consecutive address units at addr2. After MOVE
-** completes, the u consecutive address units at addr2 contain exactly
-** what the u consecutive address units at addr1 contained before the move.
-** NOTE! This implementation assumes that a char is the same size as
-** an address unit.
-**************************************************************************/
-static void move(FICL_VM *pVM)
-{
- FICL_UNS u;
- char *addr2;
- char *addr1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,0);
-#endif
-
- u = POPUNS();
- addr2 = POPPTR();
- addr1 = POPPTR();
-
- if (u == 0)
- return;
- /*
- ** Do the copy carefully, so as to be
- ** correct even if the two ranges overlap
- */
- if (addr1 >= addr2)
- {
- for (; u > 0; u--)
- *addr2++ = *addr1++;
- }
- else
- {
- addr2 += u-1;
- addr1 += u-1;
- for (; u > 0; u--)
- *addr2-- = *addr1--;
- }
-
- return;
-}
-
-
-/**************************************************************************
- r e c u r s e
-**
-**************************************************************************/
-static void recurseCoIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
-
- IGNORE(pVM);
- dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
- return;
-}
-
-
-/**************************************************************************
- s t o d
-** s-to-d CORE ( n -- d )
-** Convert the number n to the double-cell number d with the same
-** numerical value.
-**************************************************************************/
-static void sToD(FICL_VM *pVM)
-{
- FICL_INT s;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- s = POPINT();
-
- /* sign extend to 64 bits.. */
- PUSHINT(s);
- PUSHINT((s < 0) ? -1 : 0);
- return;
-}
-
-
-/**************************************************************************
- s o u r c e
-** CORE ( -- c-addr u )
-** c-addr is the address of, and u is the number of characters in, the
-** input buffer.
-**************************************************************************/
-static void source(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,2);
-#endif
- PUSHPTR(pVM->tib.cp);
- PUSHINT(vmGetInBufLen(pVM));
- return;
-}
-
-
-/**************************************************************************
- v e r s i o n
-** non-standard...
-**************************************************************************/
-static void ficlVersion(FICL_VM *pVM)
-{
- vmTextOut(pVM, "ficl Version " FICL_VER, 1);
- return;
-}
-
-
-/**************************************************************************
- t o I n
-** to-in CORE
-**************************************************************************/
-static void toIn(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,1);
-#endif
- PUSHPTR(&pVM->tib.index);
- return;
-}
-
-
-/**************************************************************************
- c o l o n N o N a m e
-** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
-** Create an unnamed colon definition and push its address.
-** Change state to compile.
-**************************************************************************/
-static void colonNoName(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
- STRINGINFO si;
-
- SI_SETLEN(si, 0);
- SI_SETPTR(si, NULL);
-
- pVM->state = COMPILE;
- pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
- PUSHPTR(pFW);
- markControlTag(pVM, colonTag);
- return;
-}
-
-
-/**************************************************************************
- u s e r V a r i a b l e
-** user ( u -- ) "<spaces>name"
-** Get a name from the input stream and create a user variable
-** with the name and the index supplied. The run-time effect
-** of a user variable is to push the address of the indexed cell
-** in the running vm's user array.
-**
-** User variables are vm local cells. Each vm has an array of
-** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
-** Ficl's user facility is implemented with two primitives,
-** "user" and "(user)", a variable ("nUser") (in softcore.c) that
-** holds the index of the next free user cell, and a redefinition
-** (also in softcore) of "user" that defines a user word and increments
-** nUser.
-**************************************************************************/
-#if FICL_WANT_USER
-static void userParen(FICL_VM *pVM)
-{
- FICL_INT i = pVM->runningWord->param[0].i;
- PUSHPTR(&pVM->user[i]);
- return;
-}
-
-
-static void userVariable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
- CELL c;
-
- c = stackPop(pVM->pStack);
- if (c.i >= FICL_USER_CELLS)
- {
- vmThrowErr(pVM, "Error - out of user space");
- }
-
- dictAppendWord2(dp, si, userParen, FW_DEFAULT);
- dictAppendCell(dp, c);
- return;
-}
-#endif
-
-
-/**************************************************************************
- t o V a l u e
-** CORE EXT
-** Interpretation: ( x "<spaces>name" -- )
-** Skip leading spaces and parse name delimited by a space. Store x in
-** name. An ambiguous condition exists if name was not defined by VALUE.
-** NOTE: In ficl, VALUE is an alias of CONSTANT
-**************************************************************************/
-static void toValue(FICL_VM *pVM)
-{
- STRINGINFO si = vmGetWord(pVM);
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
-
-#if FICL_WANT_LOCALS
- 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(pVM->pSys->pToLocalParen));
- dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
- return;
- }
- else if (pFW && pFW->code == do2LocalIm)
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
- dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
- return;
- }
- }
-#endif
-
- assert(pVM->pSys->pStore);
-
- pFW = dictLookup(dp, si);
- if (!pFW)
- {
- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
-
- if (pVM->state == INTERPRET)
- pFW->param[0] = stackPop(pVM->pStack);
- else /* compile code to store to word's param */
- {
- PUSHPTR(&pFW->param[0]);
- literalIm(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
- }
- return;
-}
-
-
-#if FICL_WANT_LOCALS
-/**************************************************************************
- l i n k P a r e n
-** ( -- )
-** Link a frame on the return stack, reserving nCells of space for
-** locals - the value of nCells is the next cell in the instruction
-** stream.
-**************************************************************************/
-static void linkParen(FICL_VM *pVM)
-{
- FICL_INT nLink = *(FICL_INT *)(pVM->ip);
- vmBranchRelative(pVM, 1);
- stackLink(pVM->rStack, nLink);
- return;
-}
-
-
-static void unlinkParen(FICL_VM *pVM)
-{
- stackUnlink(pVM->rStack);
- return;
-}
-
-
-/**************************************************************************
- d o L o c a l I m
-** Immediate - cfa of a local while compiling - when executed, compiles
-** code to fetch the value of a local given the local's index in the
-** word's pfa
-**************************************************************************/
-static void getLocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- return;
-}
-
-
-static void toLocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void getLocal0(FICL_VM *pVM)
-{
- stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
- return;
-}
-
-
-static void toLocal0(FICL_VM *pVM)
-{
- pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void getLocal1(FICL_VM *pVM)
-{
- stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
- return;
-}
-
-
-static void toLocal1(FICL_VM *pVM)
-{
- pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
- return;
-}
-
-
-/*
-** Each local is recorded in a private locals dictionary as a
-** word that does doLocalIm at runtime. DoLocalIm compiles code
-** into the client definition to fetch the value of the
-** corresponding local variable from the return stack.
-** The private dictionary gets initialized at the end of each block
-** that uses locals (in ; and does> for example).
-*/
-static void doLocalIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_INT nLocal = pVM->runningWord->param[0].i;
-
- if (pVM->state == INTERPRET)
- {
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- }
- else
- {
-
- if (nLocal == 0)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
- }
- else if (nLocal == 1)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocal));
- }
- }
- return;
-}
-
-
-/**************************************************************************
- l o c a l P a r e n
-** paren-local-paren LOCAL
-** Interpretation: Interpretation semantics for this word are undefined.
-** Execution: ( c-addr u -- )
-** When executed during compilation, (LOCAL) passes a message to the
-** system that has one of two meanings. If u is non-zero,
-** the message identifies a new local whose definition name is given by
-** the string of characters identified by c-addr u. If u is zero,
-** the message is last local and c-addr has no significance.
-**
-** The result of executing (LOCAL) during compilation of a definition is
-** to create a set of named local identifiers, each of which is
-** a definition name, that only have execution semantics within the scope
-** of that definition's source.
-**
-** local Execution: ( -- x )
-**
-** Push the local's value, x, onto the stack. The local's value is
-** initialized as described in 13.3.3 Processing locals and may be
-** changed by preceding the local's name with TO. An ambiguous condition
-** exists when local is executed while in interpretation state.
-**************************************************************************/
-static void localParen(FICL_VM *pVM)
-{
- FICL_DICT *pDict;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,0);
-#endif
-
- pDict = vmGetDict(pVM);
- SI_SETLEN(si, POPUNS());
- SI_SETPTR(si, (char *)POPPTR());
-
- if (SI_COUNT(si) > 0)
- { /* add a local to the **locals** dict and update nLocals */
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
- {
- vmThrowErr(pVM, "Error: out of local space");
- }
-
- dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
-
- if (pVM->pSys->nLocals == 0)
- { /* compile code to create a local stack frame */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
- /* save location in dictionary for #locals */
- pVM->pSys->pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- /* compile code to initialize first local */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
- }
- else if (pVM->pSys->nLocals == 1)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- }
-
- (pVM->pSys->nLocals)++;
- }
- else if (pVM->pSys->nLocals > 0)
- { /* write nLocals to (link) param area in dictionary */
- *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
- }
-
- return;
-}
-
-
-static void get2LocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
- return;
-}
-
-
-static void do2LocalIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_INT nLocal = pVM->runningWord->param[0].i;
-
- if (pVM->state == INTERPRET)
- {
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocal));
- }
- return;
-}
-
-
-static void to2LocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
- pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void twoLocalParen(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
-
- if (SI_COUNT(si) > 0)
- { /* add a local to the **locals** dict and update nLocals */
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
- {
- vmThrowErr(pVM, "Error: out of local space");
- }
-
- dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
-
- if (pVM->pSys->nLocals == 0)
- { /* compile code to create a local stack frame */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
- /* save location in dictionary for #locals */
- pVM->pSys->pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- }
-
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
-
- pVM->pSys->nLocals += 2;
- }
- else if (pVM->pSys->nLocals > 0)
- { /* write nLocals to (link) param area in dictionary */
- *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
- }
-
- return;
-}
-
-
-#endif
-/**************************************************************************
- c o m p a r e
-** STRING ( c-addr1 u1 c-addr2 u2 -- n )
-** Compare the string specified by c-addr1 u1 to the string specified by
-** c-addr2 u2. The strings are compared, beginning at the given addresses,
-** character by character, up to the length of the shorter string or until a
-** difference is found. If the two strings are identical, n is zero. If the two
-** strings are identical up to the length of the shorter string, n is minus-one
-** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
-** identical up to the length of the shorter string, n is minus-one (-1) if the
-** first non-matching character in the string specified by c-addr1 u1 has a
-** lesser numeric value than the corresponding character in the string specified
-** by c-addr2 u2 and one (1) otherwise.
-**************************************************************************/
-static void compareInternal(FICL_VM *pVM, int caseInsensitive)
-{
- char *cp1, *cp2;
- FICL_UNS u1, u2, uMin;
- int n = 0;
-
- vmCheckStack(pVM, 4, 1);
- u2 = stackPopUNS(pVM->pStack);
- cp2 = (char *)stackPopPtr(pVM->pStack);
- u1 = stackPopUNS(pVM->pStack);
- cp1 = (char *)stackPopPtr(pVM->pStack);
-
- uMin = (u1 < u2)? u1 : u2;
- for ( ; (uMin > 0) && (n == 0); uMin--)
- {
- char c1 = *cp1++;
- char c2 = *cp2++;
- if (caseInsensitive)
- {
- c1 = (char)tolower(c1);
- c2 = (char)tolower(c2);
- }
- n = (int)(c1 - c2);
- }
-
- if (n == 0)
- n = (int)(u1 - u2);
-
- if (n < 0)
- n = -1;
- else if (n > 0)
- n = 1;
-
- PUSHINT(n);
- return;
-}
-
-
-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:
-**
-** SOURCE-ID Input source
-** --------- ------------
-** fileid Text file fileid
-** -1 String (via EVALUATE)
-** 0 User input device
-**************************************************************************/
-static void sourceid(FICL_VM *pVM)
-{
- PUSHINT(pVM->sourceID.i);
- return;
-}
-
-
-/**************************************************************************
- r e f i l l
-** CORE EXT ( -- flag )
-** Attempt to fill the input buffer from the input source, returning a true
-** flag if successful.
-** When the input source is the user input device, attempt to receive input
-** into the terminal input buffer. If successful, make the result the input
-** buffer, set >IN to zero, and return true. Receipt of a line containing no
-** characters is considered successful. If there is no input available from
-** the current input source, return false.
-** When the input source is a string from EVALUATE, return false and
-** perform no other action.
-**************************************************************************/
-static void refill(FICL_VM *pVM)
-{
- FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
- if (ret && (pVM->fRestart == 0))
- vmThrow(pVM, VM_RESTART);
-
- PUSHINT(ret);
- return;
-}
-
-
-/**************************************************************************
- freebsd exception handling words
-** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
-** the word in ToS. If an exception happens, restore the state to what
-** it was before, and pushes the exception value on the stack. If not,
-** push zero.
-**
-** Notice that Catch implements an inner interpreter. This is ugly,
-** but given how ficl works, it cannot be helped. The problem is that
-** colon definitions will be executed *after* the function returns,
-** while "code" definitions will be executed immediately. I considered
-** other solutions to this problem, but all of them shared the same
-** basic problem (with added disadvantages): if ficl ever changes it's
-** inner thread modus operandi, one would have to fix this word.
-**
-** More comments can be found throughout catch's code.
-**
-** Daniel C. Sobral Jan 09/1999
-** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
-**************************************************************************/
-
-static void ficlCatch(FICL_VM *pVM)
-{
- int except;
- jmp_buf vmState;
- FICL_VM VM;
- FICL_STACK pStack;
- FICL_STACK rStack;
- FICL_WORD *pFW;
-
- assert(pVM);
- assert(pVM->pSys->pExitInner);
-
-
- /*
- ** Get xt.
- ** We need this *before* we save the stack pointer, or
- ** we'll have to pop one element out of the stack after
- ** an exception. I prefer to get done with it up front. :-)
- */
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- pFW = stackPopPtr(pVM->pStack);
-
- /*
- ** Save vm's state -- a catch will not back out environmental
- ** changes.
- **
- ** We are *not* saving dictionary state, since it is
- ** global instead of per vm, and we are not saving
- ** stack contents, since we are not required to (and,
- ** thus, it would be useless). We save pVM, and pVM
- ** "stacks" (a structure containing general information
- ** about it, including the current stack pointer).
- */
- memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
- memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
- memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
-
- /*
- ** Give pVM a jmp_buf
- */
- pVM->pState = &vmState;
-
- /*
- ** Safety net
- */
- except = setjmp(vmState);
-
- switch (except)
- {
- /*
- ** Setup condition - push poison pill so that the VM throws
- ** VM_INNEREXIT if the XT terminates normally, then execute
- ** the XT
- */
- case 0:
- vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
- vmExecute(pVM, pFW);
- vmInnerLoop(pVM);
- break;
-
- /*
- ** Normal exit from XT - lose the poison pill,
- ** restore old setjmp vector and push a zero.
- */
- case VM_INNEREXIT:
- vmPopIP(pVM); /* Gack - hurl poison pill */
- pVM->pState = VM.pState; /* Restore just the setjmp vector */
- PUSHINT(0); /* Push 0 -- everything is ok */
- break;
-
- /*
- ** Some other exception got thrown - restore pre-existing VM state
- ** and push the exception code
- */
- default:
- /* Restore vm's state */
- memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
- memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
- memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
-
- PUSHINT(except);/* Push error */
- break;
- }
-}
-
-/**************************************************************************
-** t h r o w
-** EXCEPTION
-** Throw -- From ANS Forth standard.
-**
-** Throw takes the ToS and, if that's different from zero,
-** returns to the last executed catch context. Further throws will
-** unstack previously executed "catches", in LIFO mode.
-**
-** Daniel C. Sobral Jan 09/1999
-**************************************************************************/
-static void ficlThrow(FICL_VM *pVM)
-{
- int except;
-
- except = stackPopINT(pVM->pStack);
-
- if (except)
- vmThrow(pVM, except);
-}
-
-
-/**************************************************************************
-** a l l o c a t e
-** MEMORY
-**************************************************************************/
-static void ansAllocate(FICL_VM *pVM)
-{
- size_t size;
- void *p;
-
- size = stackPopINT(pVM->pStack);
- p = ficlMalloc(size);
- PUSHPTR(p);
- if (p)
- PUSHINT(0);
- else
- PUSHINT(1);
-}
-
-
-/**************************************************************************
-** f r e e
-** MEMORY
-**************************************************************************/
-static void ansFree(FICL_VM *pVM)
-{
- void *p;
-
- p = stackPopPtr(pVM->pStack);
- ficlFree(p);
- PUSHINT(0);
-}
-
-
-/**************************************************************************
-** r e s i z e
-** MEMORY
-**************************************************************************/
-static void ansResize(FICL_VM *pVM)
-{
- size_t size;
- void *new, *old;
-
- size = stackPopINT(pVM->pStack);
- old = stackPopPtr(pVM->pStack);
- new = ficlRealloc(old, size);
- if (new)
- {
- PUSHPTR(new);
- PUSHINT(0);
- }
- else
- {
- PUSHPTR(old);
- PUSHINT(1);
- }
-}
-
-
-/**************************************************************************
-** e x i t - i n n e r
-** Signals execXT that an inner loop has completed
-**************************************************************************/
-static void ficlExitInner(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_INNEREXIT);
-}
-
-
-/**************************************************************************
- d n e g a t e
-** DOUBLE ( d1 -- d2 )
-** d2 is the negation of d1.
-**************************************************************************/
-static void dnegate(FICL_VM *pVM)
-{
- DPINT i = i64Pop(pVM->pStack);
- i = m64Negate(i);
- i64Push(pVM->pStack, i);
-
- return;
-}
-
-
-#if 0
-/**************************************************************************
-
-**
-**************************************************************************/
-static void funcname(FICL_VM *pVM)
-{
- IGNORE(pVM);
- return;
-}
-
-
-#endif
-/**************************************************************************
- f i c l W o r d C l a s s i f y
-** This public function helps to classify word types for SEE
-** and the deugger in tools.c. Given an pointer to a word, it returns
-** a member of WOR
-**************************************************************************/
-WORDKIND ficlWordClassify(FICL_WORD *pFW)
-{
- typedef struct
- {
- WORDKIND kind;
- FICL_CODE code;
- } CODEtoKIND;
-
- static CODEtoKIND codeMap[] =
- {
- {BRANCH, branchParen},
- {COLON, colonParen},
- {CONSTANT, constantParen},
- {CREATE, createParen},
- {DO, doParen},
- {DOES, doDoes},
- {IF, branch0},
- {LITERAL, literalParen},
- {LOOP, loopParen},
- {OF, ofParen},
- {PLOOP, plusLoopParen},
- {QDO, qDoParen},
- {CSTRINGLIT, cstringLit},
- {STRINGLIT, stringLit},
-#if FICL_WANT_USER
- {USER, userParen},
-#endif
- {VARIABLE, variableParen},
- };
-
-#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
-
- FICL_CODE code = pFW->code;
- int i;
-
- for (i=0; i < nMAP; i++)
- {
- if (codeMap[i].code == code)
- return codeMap[i].kind;
- }
-
- return PRIMITIVE;
-}
-
-
-/**************************************************************************
-** 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());
-}
-
-
-/**************************************************************************
- f i c l C o m p i l e C o r e
-** Builds the primitive wordset and the environment-query namespace.
-**************************************************************************/
-
-void ficlCompileCore(FICL_SYSTEM *pSys)
-{
- FICL_DICT *dp = pSys->dp;
- assert (dp);
-
-
- /*
- ** CORE word set
- ** see softcore.c for definitions of: abs bl space spaces abort"
- */
- pSys->pStore =
- dictAppendWord(dp, "!", store, FW_DEFAULT);
- dictAppendWord(dp, "#", numberSign, FW_DEFAULT);
- dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT);
- dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT);
- dictAppendWord(dp, "\'", ficlTick, FW_DEFAULT);
- dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE);
- dictAppendWord(dp, "*", mul, FW_DEFAULT);
- dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT);
- dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT);
- dictAppendWord(dp, "+", add, FW_DEFAULT);
- dictAppendWord(dp, "+!", plusStore, FW_DEFAULT);
- dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED);
- dictAppendWord(dp, ",", comma, FW_DEFAULT);
- dictAppendWord(dp, "-", sub, FW_DEFAULT);
- dictAppendWord(dp, ".", displayCell, FW_DEFAULT);
- dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT);
- dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT);
- dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT);
- dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT);
- dictAppendWord(dp, "1+", onePlus, FW_DEFAULT);
- dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT);
- dictAppendWord(dp, "2!", twoStore, FW_DEFAULT);
- dictAppendWord(dp, "2*", twoMul, FW_DEFAULT);
- dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT);
- dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT);
- dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT);
- dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT);
- dictAppendWord(dp, "2over", twoOver, FW_DEFAULT);
- dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT);
- dictAppendWord(dp, ":", colon, FW_DEFAULT);
- dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "<", isLess, FW_DEFAULT);
- dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT);
- dictAppendWord(dp, "=", isEqual, FW_DEFAULT);
- dictAppendWord(dp, ">", isGreater, FW_DEFAULT);
- dictAppendWord(dp, ">body", toBody, FW_DEFAULT);
- dictAppendWord(dp, ">in", toIn, FW_DEFAULT);
- dictAppendWord(dp, ">number", toNumber, FW_DEFAULT);
- dictAppendWord(dp, ">r", toRStack, FW_COMPILE);
- dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT);
- dictAppendWord(dp, "@", fetch, FW_DEFAULT);
- dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT);
- dictAppendWord(dp, "accept", accept, FW_DEFAULT);
- dictAppendWord(dp, "align", align, FW_DEFAULT);
- dictAppendWord(dp, "aligned", aligned, FW_DEFAULT);
- dictAppendWord(dp, "allot", allot, FW_DEFAULT);
- dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT);
- dictAppendWord(dp, "base", base, FW_DEFAULT);
- dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED);
- 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);
- dictAppendWord(dp, "char+", charPlus, FW_DEFAULT);
- dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT);
- dictAppendWord(dp, "constant", constant, FW_DEFAULT);
- dictAppendWord(dp, "count", count, FW_DEFAULT);
- dictAppendWord(dp, "cr", cr, FW_DEFAULT);
- dictAppendWord(dp, "create", create, FW_DEFAULT);
- dictAppendWord(dp, "decimal", decimal, FW_DEFAULT);
- 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);
- dictAppendWord(dp, "here", here, FW_DEFAULT);
- dictAppendWord(dp, "hold", hold, FW_DEFAULT);
- dictAppendWord(dp, "i", loopICo, FW_COMPILE);
- dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "immediate", immediate, FW_DEFAULT);
- dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT);
- dictAppendWord(dp, "j", loopJCo, FW_COMPILE);
- dictAppendWord(dp, "k", loopKCo, FW_COMPILE);
- dictAppendWord(dp, "leave", leaveCo, FW_COMPILE);
- dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE);
- dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "lshift", lshift, FW_DEFAULT);
- dictAppendWord(dp, "m*", mStar, FW_DEFAULT);
- dictAppendWord(dp, "max", ficlMax, FW_DEFAULT);
- dictAppendWord(dp, "min", ficlMin, FW_DEFAULT);
- 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);
- dictAppendWord(dp, "quit", quit, FW_DEFAULT);
- dictAppendWord(dp, "r>", fromRStack, FW_COMPILE);
- dictAppendWord(dp, "r@", fetchRStack, FW_COMPILE);
- dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "rot", rot, FW_DEFAULT);
- dictAppendWord(dp, "rshift", rshift, FW_DEFAULT);
- dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE);
- dictAppendWord(dp, "s>d", sToD, FW_DEFAULT);
- dictAppendWord(dp, "sign", sign, FW_DEFAULT);
- dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT);
- dictAppendWord(dp, "source", source, FW_DEFAULT);
- dictAppendWord(dp, "state", state, FW_DEFAULT);
- dictAppendWord(dp, "swap", swap, FW_DEFAULT);
- dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "type", type, FW_DEFAULT);
- dictAppendWord(dp, "u.", uDot, FW_DEFAULT);
- dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT);
- dictAppendWord(dp, "um*", umStar, FW_DEFAULT);
- dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT);
- dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE);
- dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "variable", variable, FW_DEFAULT);
- dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "word", ficlWord, FW_DEFAULT);
- dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT);
- dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED);
- dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "]", rbracket, FW_DEFAULT);
- /*
- ** CORE EXT word set...
- ** see softcore.fr for other definitions
- */
- /* "#tib" */
- dictAppendWord(dp, ".(", dotParen, FW_IMMEDIATE);
- /* ".r" */
- dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT);
- dictAppendWord(dp, "2>r", twoToR, FW_COMPILE);
- dictAppendWord(dp, "2r>", twoRFrom, FW_COMPILE);
- dictAppendWord(dp, "2r@", twoRFetch, FW_COMPILE);
- dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT);
- dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED);
- dictAppendWord(dp, "c\"", cstringQuoteIm, FW_IMMEDIATE);
- dictAppendWord(dp, "hex", hex, FW_DEFAULT);
- dictAppendWord(dp, "pad", pad, FW_DEFAULT);
- dictAppendWord(dp, "parse", parse, FW_DEFAULT);
- dictAppendWord(dp, "pick", pick, FW_DEFAULT);
- /* query restore-input save-input tib u.r u> unused [compile] */
- dictAppendWord(dp, "roll", roll, FW_DEFAULT);
- dictAppendWord(dp, "refill", refill, FW_DEFAULT);
- dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT);
- dictAppendWord(dp, "to", toValue, FW_IMMEDIATE);
- dictAppendWord(dp, "value", constant, FW_DEFAULT);
- dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE);
-
-
- /*
- ** Set CORE environment query values
- */
- ficlSetEnv(pSys, "/counted-string", FICL_STRING_MAX);
- ficlSetEnv(pSys, "/hold", nPAD);
- ficlSetEnv(pSys, "/pad", nPAD);
- ficlSetEnv(pSys, "address-unit-bits", 8);
- ficlSetEnv(pSys, "core", FICL_TRUE);
- ficlSetEnv(pSys, "core-ext", FICL_FALSE);
- ficlSetEnv(pSys, "floored", FICL_FALSE);
- ficlSetEnv(pSys, "max-char", UCHAR_MAX);
- ficlSetEnvD(pSys,"max-d", 0x7fffffff, 0xffffffff);
- ficlSetEnv(pSys, "max-n", 0x7fffffff);
- ficlSetEnv(pSys, "max-u", 0xffffffff);
- ficlSetEnvD(pSys,"max-ud", 0xffffffff, 0xffffffff);
- ficlSetEnv(pSys, "return-stack-cells",FICL_DEFAULT_STACK);
- ficlSetEnv(pSys, "stack-cells", FICL_DEFAULT_STACK);
-
- /*
- ** DOUBLE word set (partial)
- */
- dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE);
- dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE);
- dictAppendWord(dp, "2variable", twoVariable, FW_IMMEDIATE);
- dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT);
-
-
- /*
- ** EXCEPTION word set
- */
- dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT);
- dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT);
-
- ficlSetEnv(pSys, "exception", FICL_TRUE);
- ficlSetEnv(pSys, "exception-ext", FICL_TRUE);
-
- /*
- ** LOCAL and LOCAL EXT
- ** see softcore.c for implementation of locals|
- */
-#if FICL_WANT_LOCALS
- pSys->pLinkParen =
- dictAppendWord(dp, "(link)", linkParen, FW_COMPILE);
- pSys->pUnLinkParen =
- dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE);
- dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED);
- pSys->pGetLocalParen =
- dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE);
- pSys->pToLocalParen =
- dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE);
- pSys->pGetLocal0 =
- dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE);
- pSys->pToLocal0 =
- dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE);
- pSys->pGetLocal1 =
- dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE);
- pSys->pToLocal1 =
- dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE);
- dictAppendWord(dp, "(local)", localParen, FW_COMPILE);
-
- pSys->pGet2LocalParen =
- dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
- pSys->pTo2LocalParen =
- dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE);
- dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE);
-
- ficlSetEnv(pSys, "locals", FICL_TRUE);
- ficlSetEnv(pSys, "locals-ext", FICL_TRUE);
- ficlSetEnv(pSys, "#locals", FICL_MAX_LOCALS);
-#endif
-
- /*
- ** Optional MEMORY-ALLOC word set
- */
-
- dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT);
- dictAppendWord(dp, "free", ansFree, FW_DEFAULT);
- dictAppendWord(dp, "resize", ansResize, FW_DEFAULT);
-
- ficlSetEnv(pSys, "memory-alloc", FICL_TRUE);
-
- /*
- ** optional SEARCH-ORDER word set
- */
- ficlCompileSearch(pSys);
-
- /*
- ** TOOLS and TOOLS EXT
- */
- 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);
- dictAppendWord(dp, "add-parse-step",
- 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);
- dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
- dictAppendWord(dp, "hash", hash, FW_DEFAULT);
- dictAppendWord(dp, "objectify", setObjectFlag, FW_DEFAULT);
- dictAppendWord(dp, "?object", isObject, 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);
- dictAppendWord(dp, "w!", wStore, FW_DEFAULT);
- dictAppendWord(dp, "x.", hexDot, FW_DEFAULT);
-#if FICL_WANT_USER
- dictAppendWord(dp, "(user)", userParen, FW_DEFAULT);
- dictAppendWord(dp, "user", userVariable, FW_DEFAULT);
-#endif
- dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT);
- dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT);
-
- /*
- ** internal support words
- */
- dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
- pSys->pExitParen =
- dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
- pSys->pSemiParen =
- dictAppendWord(dp, "(;)", semiParen, FW_COMPILE);
- pSys->pLitParen =
- dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE);
- pSys->pTwoLitParen =
- dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE);
- pSys->pStringLit =
- dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE);
- pSys->pCStringLit =
- dictAppendWord(dp, "(c\")", cstringLit, FW_COMPILE);
- pSys->pBranch0 =
- dictAppendWord(dp, "(branch0)", branch0, FW_COMPILE);
- pSys->pBranchParen =
- dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE);
- pSys->pDoParen =
- dictAppendWord(dp, "(do)", doParen, FW_COMPILE);
- pSys->pDoesParen =
- dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE);
- pSys->pQDoParen =
- dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE);
- pSys->pLoopParen =
- dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE);
- pSys->pPLoopParen =
- dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE);
- 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)",
- 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);
-
- return;
-}
-