summaryrefslogtreecommitdiffstats
path: root/stand/ficl
diff options
context:
space:
mode:
authorkevans <kevans@FreeBSD.org>2018-02-12 01:08:44 +0000
committerkevans <kevans@FreeBSD.org>2018-02-12 01:08:44 +0000
commit7d97ee5b28b409c00bfaf12daf5ab497a6038b9d (patch)
tree245306b754606bcf49c0ff17b131b58609b6c7a6 /stand/ficl
parent43b278e1b66cf4de337a17034087ea785031bd6f (diff)
downloadFreeBSD-src-7d97ee5b28b409c00bfaf12daf5ab497a6038b9d.zip
FreeBSD-src-7d97ee5b28b409c00bfaf12daf5ab497a6038b9d.tar.gz
MFC r325834,r325997,326502: Move sys/boot to stand/
This is effectively a direct commit to stable/11, due to differences between stable/11 and head. Changes to DTS in sys/boot/fdt/dts were often accompanied by kernel changes. Many of these were also risc-v updates that likely had many more dependencies to MFC. Because of this, sys/boot/fdt/dts remains as-is while everything else in sys/boot relocates to stand/. r325834: Move sys/boot to stand. Fix all references to new location r325997: Remove empty directories. r326502: Document the sys/boot -> stand move in hier.7 and the top-level README.
Diffstat (limited to 'stand/ficl')
-rw-r--r--stand/ficl/Makefile32
-rw-r--r--stand/ficl/Makefile.depend15
-rw-r--r--stand/ficl/aarch64/sysdep.c99
-rw-r--r--stand/ficl/aarch64/sysdep.h411
-rw-r--r--stand/ficl/amd64/sysdep.c99
-rw-r--r--stand/ficl/amd64/sysdep.h434
-rw-r--r--stand/ficl/arm/sysdep.c99
-rw-r--r--stand/ficl/arm/sysdep.h432
-rw-r--r--stand/ficl/dict.c864
-rw-r--r--stand/ficl/ficl.c696
-rw-r--r--stand/ficl/ficl.h1164
-rw-r--r--stand/ficl/fileaccess.c425
-rw-r--r--stand/ficl/float.c1067
-rw-r--r--stand/ficl/i386/sysdep.c149
-rw-r--r--stand/ficl/i386/sysdep.h432
-rw-r--r--stand/ficl/loader.c841
-rw-r--r--stand/ficl/math64.c561
-rw-r--r--stand/ficl/math64.h88
-rw-r--r--stand/ficl/mips/sysdep.c99
-rw-r--r--stand/ficl/mips/sysdep.h432
-rw-r--r--stand/ficl/mips64/sysdep.c99
-rw-r--r--stand/ficl/mips64/sysdep.h432
-rw-r--r--stand/ficl/powerpc/sysdep.c99
-rw-r--r--stand/ficl/powerpc/sysdep.h432
-rw-r--r--stand/ficl/prefix.c199
-rw-r--r--stand/ficl/riscv/sysdep.c99
-rw-r--r--stand/ficl/riscv/sysdep.h411
-rw-r--r--stand/ficl/search.c393
-rw-r--r--stand/ficl/softwords/classes.fr173
-rw-r--r--stand/ficl/softwords/ficlclass.fr86
-rw-r--r--stand/ficl/softwords/ficllocal.fr49
-rw-r--r--stand/ficl/softwords/fileaccess.fr25
-rw-r--r--stand/ficl/softwords/forml.fr75
-rw-r--r--stand/ficl/softwords/freebsd.fr36
-rw-r--r--stand/ficl/softwords/ifbrack.fr50
-rw-r--r--stand/ficl/softwords/jhlocal.fr105
-rw-r--r--stand/ficl/softwords/marker.fr27
-rw-r--r--stand/ficl/softwords/oo.fr694
-rw-r--r--stand/ficl/softwords/prefix.fr59
-rw-r--r--stand/ficl/softwords/softcore.awk183
-rw-r--r--stand/ficl/softwords/softcore.fr206
-rw-r--r--stand/ficl/softwords/string.fr148
-rw-r--r--stand/ficl/sparc64/sysdep.c99
-rw-r--r--stand/ficl/sparc64/sysdep.h412
-rw-r--r--stand/ficl/stack.c372
-rw-r--r--stand/ficl/testmain.c345
-rw-r--r--stand/ficl/tools.c918
-rw-r--r--stand/ficl/unix.c23
-rw-r--r--stand/ficl/vm.c805
-rw-r--r--stand/ficl/words.c5208
50 files changed, 20701 insertions, 0 deletions
diff --git a/stand/ficl/Makefile b/stand/ficl/Makefile
new file mode 100644
index 0000000..9a13614
--- /dev/null
+++ b/stand/ficl/Makefile
@@ -0,0 +1,32 @@
+# $FreeBSD$
+#
+
+.include <bsd.init.mk>
+.include "${BOOTSRC}/ficl.mk"
+
+BASE_SRCS= dict.c ficl.c fileaccess.c float.c loader.c math64.c \
+ prefix.c search.c stack.c tools.c vm.c words.c
+
+SRCS= ${BASE_SRCS} sysdep.c softcore.c
+CLEANFILES+= softcore.c testmain testmain.o
+
+.include <bsd.stand.mk>
+.ifmake testmain
+CFLAGS+= -DTESTMAIN -D_TESTMAIN
+SRCS+= testmain.c
+PROG= testmain
+.include <bsd.prog.mk>
+.else
+LIB= ficl
+INTERNALLIB=
+.include <bsd.lib.mk>
+.endif
+
+# Standard softwords
+.PATH: ${FICLSRC}/softwords
+SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr ficllocal.fr \
+ ifbrack.fr
+
+softcore.c: ${SOFTWORDS} softcore.awk
+ (cd ${FICLSRC}/softwords; cat ${SOFTWORDS} \
+ | awk -f softcore.awk -v datestamp="`LC_ALL=C date`") > ${.TARGET}
diff --git a/stand/ficl/Makefile.depend b/stand/ficl/Makefile.depend
new file mode 100644
index 0000000..c04b7c3
--- /dev/null
+++ b/stand/ficl/Makefile.depend
@@ -0,0 +1,15 @@
+# $FreeBSD$
+# Autogenerated - do NOT edit!
+
+DIRDEPS = \
+ include \
+ include/xlocale \
+ lib/libstand \
+ lib/msun \
+
+
+.include <dirdeps.mk>
+
+.if ${DEP_RELDIR} == ${_DEP_RELDIR}
+# local dependencies - needed for -jN in clean tree
+.endif
diff --git a/stand/ficl/aarch64/sysdep.c b/stand/ficl/aarch64/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/aarch64/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/aarch64/sysdep.h b/stand/ficl/aarch64/sysdep.h
new file mode 100644
index 0000000..3726b9e
--- /dev/null
+++ b/stand/ficl/aarch64/sysdep.h
@@ -0,0 +1,411 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#if !defined IGNORE /* Macro to silence unused param warnings */
+#define IGNORE(x) (void)(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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 long
+#endif
+
+#if !defined FICL_UNS
+#define FICL_UNS unsigned long
+#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 64
+#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_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
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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 3
+#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);
+
+#endif /*__SYSDEP_H__*/
diff --git a/stand/ficl/amd64/sysdep.c b/stand/ficl/amd64/sysdep.c
new file mode 100644
index 0000000..5957b71
--- /dev/null
+++ b/stand/ficl/amd64/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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((unsigned char)*(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 */
diff --git a/stand/ficl/amd64/sysdep.h b/stand/ficl/amd64/sysdep.h
new file mode 100644
index 0000000..08bc0e1
--- /dev/null
+++ b/stand/ficl/amd64/sysdep.h
@@ -0,0 +1,434 @@
+/*******************************************************************
+ 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/12/05 07:21:34 jsadler 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+*/
+
+/* $FreeBSD$ */
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#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
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 long
+#endif
+
+#if !defined FICL_UNS
+#define FICL_UNS unsigned long
+#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 64
+#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
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#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 260
+#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 3
+#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/stand/ficl/arm/sysdep.c b/stand/ficl/arm/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/arm/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/arm/sysdep.h b/stand/ficl/arm/sysdep.h
new file mode 100644
index 0000000..00718ee
--- /dev/null
+++ b/stand/ficl/arm/sysdep.h
@@ -0,0 +1,432 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#if !defined IGNORE /* Macro to silence unused param warnings */
+#define IGNORE(x) (void)(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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 1
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_PLATFORM_EXTEND
+** Includes words defined in ficlCompilePlatform
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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) /* 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/stand/ficl/dict.c b/stand/ficl/dict.c
new file mode 100644
index 0000000..b76d925
--- /dev/null
+++ b/stand/ficl/dict.c
@@ -0,0 +1,864 @@
+/*******************************************************************
+** 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.14 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <ctype.h>
+#else
+#include <stand.h>
+#endif
+#include <string.h>
+#include "ficl.h"
+
+/* Dictionary on-demand resizing control variables */
+CELL dictThreshold;
+CELL dictIncrease;
+
+
+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_HASH) + nCells * sizeof (CELL)
+ + (nHash - 1) * sizeof (FICL_WORD *);
+
+ pDict = ficlMalloc(sizeof (FICL_DICT));
+ assert(pDict);
+ memset(pDict, 0, sizeof (FICL_DICT));
+ pDict->dict = ficlMalloc(nAlloc);
+ assert(pDict->dict);
+
+ 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;
+}
+
+/**************************************************************************
+ d i c t C h e c k T h r e s h o l d
+** Verify if an increase in the dictionary size is warranted, and do it if
+** so.
+**************************************************************************/
+
+void dictCheckThreshold(FICL_DICT* dp)
+{
+ if( dictCellsAvail(dp) < dictThreshold.u ) {
+ dp->dict = ficlMalloc( dictIncrease.u * sizeof (CELL) );
+ assert(dp->dict);
+ dp->here = dp->dict;
+ dp->size = dictIncrease.u;
+ dictAlign(dp);
+ }
+}
+
diff --git a/stand/ficl/ficl.c b/stand/ficl/ficl.c
new file mode 100644
index 0000000..219cf84
--- /dev/null
+++ b/stand/ficl/ficl.c
@@ -0,0 +1,696 @@
+/*******************************************************************
+** 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.16 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#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 != NULL);
+
+ 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);
+#ifdef TESTMAIN
+ if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
+ ficlTextOut(pVM, FICL_PROMPT, 0);
+#endif
+ 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)
+{
+ ficlSetEnvD(pSys, "ficl-version", FICL_VER_MAJOR, FICL_VER_MINOR);
+ ficlSetEnv (pSys, "ficl-robust", FICL_ROBUST);
+ return;
+}
+
diff --git a/stand/ficl/ficl.h b/stand/ficl/ficl.h
new file mode 100644
index 0000000..8829cce
--- /dev/null
+++ b/stand/ficl/ficl.h
@@ -0,0 +1,1164 @@
+/*******************************************************************
+** f i c l . h
+** Forth Inspired Command Language
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+** Dedicated to RHS, in loving memory
+** $Id: ficl.h,v 1.18 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#if !defined (__FICL_H__)
+#define __FICL_H__
+/*
+** Ficl (Forth-inspired command language) is an ANS Forth
+** interpreter written in C. Unlike traditional Forths, this
+** interpreter is designed to be embedded into other systems
+** as a command/macro/development prototype language.
+**
+** 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).
+**
+** 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. This
+** is more like TCL than Forth, which usually expcets 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
+** machines share a common dictionary (a sort or open symbol table that
+** defines all of the elements of the language).
+**
+** Code is written in ANSI C for portability.
+**
+** Summary of Ficl features and constraints:
+** - Standard: Implements the ANSI Forth CORE word set and part
+** of the CORE EXT word-set, SEARCH and SEARCH EXT, TOOLS and
+** TOOLS EXT, LOCAL and LOCAL ext and various extras.
+** - 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!
+** - Ficl and C can interact in two ways: Ficl can encapsulate
+** C code, or C code can invoke Ficl code.
+** - Thread-safe, re-entrant: The shared system dictionary
+** uses a locking mechanism that you can either supply
+** or stub out to provide exclusive access. Each Ficl
+** virtual machine has an otherwise complete state, and
+** each can be bound to a separate I/O channel (or none at all).
+** - Simple encapsulation into existing systems: a basic implementation
+** requires three function calls (see the example program in testmain.c).
+** - 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.
+** - Written an 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++ 5.
+** - Does full 32 bit math (but you need to implement
+** two mixed precision math primitives (see sysdep.c))
+** - Indirect threaded interpreter is not the fastest kind of
+** Forth there is (see pForth 68K for a really fast subroutine
+** threaded interpreter), but it's the cleanest match to a
+** pure C implementation.
+**
+** P O R T I N G F i c l
+**
+** 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 sysdep.h and sysdep.c and edit them to suit your
+** 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.
+**
+** T o D o L i s t
+**
+** 1. Unimplemented system dependent CORE word: key
+** 2. Ficl uses the PAD in some CORE words - this violates the standard,
+** but it's cleaner for a multithreaded system. I'll have to make a
+** second pad for reference by the word PAD to fix this.
+**
+** F o r M o r e I n f o r m a t i o n
+**
+** 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
+**
+** 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.
+**
+*/
+
+/*
+** 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.
+**
+** 10 Jan 1999 (sobral) EXCEPTION word set has been added, and existing
+** words has been modified to conform to EXCEPTION EXT word set.
+**
+** 27 Aug 1998 (sadler) testing and corrections for LOCALS, LOCALS EXT,
+** SEARCH / SEARCH EXT, TOOLS / TOOLS EXT.
+** Added .X to display in hex, PARSE and PARSE-WORD to supplement WORD,
+** EMPTY to clear stack.
+**
+** 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"
+**
+** 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.
+**
+** 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
+*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "sysdep.h"
+#include <limits.h> /* UCHAR_MAX */
+
+/*
+** 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;
+
+/*
+** the Good Stuff starts here...
+*/
+#define FICL_VER "3.03"
+#define FICL_VER_MAJOR 3
+#define FICL_VER_MINOR 3
+#if !defined (FICL_PROMPT)
+#define FICL_PROMPT "ok> "
+#endif
+
+/*
+** ANS Forth requires false to be zero, and true to be the ones
+** complement of false... that unifies logical and bitwise operations
+** nicely.
+*/
+#define FICL_TRUE ((unsigned long)~(0L))
+#define FICL_FALSE (0)
+#define FICL_BOOL(x) ((x) ? FICL_TRUE : FICL_FALSE)
+
+
+/*
+** A CELL 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.
+*/
+typedef union _cell
+{
+ FICL_INT i;
+ FICL_UNS u;
+#if (FICL_WANT_FLOAT)
+ FICL_FLOAT f;
+#endif
+ void *p;
+ void (*fn)(void);
+} CELL;
+
+/*
+** LVALUEtoCELL 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)
+
+/*
+** 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 *)
+
+/*
+** 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.
+*/
+
+typedef unsigned char FICL_COUNT;
+#define FICL_STRING_MAX UCHAR_MAX
+typedef struct _ficl_string
+{
+ FICL_COUNT count;
+ char text[1];
+} FICL_STRING;
+
+typedef struct
+{
+ 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);}
+/*
+** Init a STRINGINFO from a pointer to FICL_STRING
+*/
+#define SI_PFS(si, pfs) \
+ {si.cp = pfs->text; si.count = pfs->count;}
+
+/*
+** Ficl uses this little structure to hold the address of
+** the block of text it's working on and an index to the next
+** unconsumed character in the string. Traditionally, this is
+** done by a Text Input Buffer, so I've called this struct TIB.
+**
+** Since this structure also holds the size of the input buffer,
+** and since evaluate requires that, let's put the size here.
+** The size is stored as an end-pointer because that is what the
+** null-terminated string aware functions find most easy to deal
+** with.
+** Notice, though, that nobody really uses this except evaluate,
+** so it might just be moved to FICL_VM instead. (sobral)
+*/
+typedef struct
+{
+ FICL_INT index;
+ char *end;
+ char *cp;
+} TIB;
+
+
+/*
+** Stacks get heavy use in Ficl and Forth...
+** Each virtual machine implements two of them:
+** one holds parameters (data), and the other holds return
+** addresses and control flow information for the virtual
+** machine. (Note: C's automatic stack is implicitly used,
+** but not modeled because it doesn't need to be...)
+** Here's an abstract type for a stack
+*/
+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;
+
+/*
+** 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);
+
+#if (FICL_WANT_FLOAT)
+float stackPopFloat (FICL_STACK *pStack);
+void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f);
+#endif
+
+/*
+** 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)
+
+/*
+** The virtual machine (VM) contains the state for one interpreter.
+** Defined operations include:
+** Create & initialize
+** Delete
+** Execute a block of text
+** Parse a word out of the input stream
+** Call return, and branch
+** Text output
+** 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);
+
+/*
+** Each VM operates in one of two non-error states: interpreting
+** or compiling. When interpreting, words are simply executed.
+** When compiling, most words in the input stream have their
+** addresses inserted into the word under construction. Some words
+** (known as IMMEDIATE) are executed in the compile state, too.
+*/
+/* values of STATE */
+#define INTERPRET 0
+#define COMPILE 1
+
+/*
+** The pad is a small scratch area for text manipulation. ANS Forth
+** requires it to hold at least 84 characters.
+*/
+#if !defined nPAD
+#define nPAD 256
+#endif
+
+/*
+** ANS Forth requires that a word's name contain {1..31} characters.
+*/
+#if !defined nFICLNAME
+#define nFICLNAME 31
+#endif
+
+/*
+** OK - now we can really define the VM...
+*/
+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) */
+};
+
+/*
+** 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
+
+/*
+** 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.
+** 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 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 */
+ 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 */
+};
+
+/*
+** Worst-case size of a word header: nFICLNAME chars in name
+*/
+#define CELLS_PER_WORD \
+ ( (sizeof (FICL_WORD) + nFICLNAME + sizeof (CELL)) \
+ / (sizeof (CELL)) )
+
+int wordIsImmediate(FICL_WORD *pFW);
+int wordIsCompileOnly(FICL_WORD *pFW);
+
+/* 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 */
+
+#define FW_COMPIMMED (FW_IMMEDIATE | FW_COMPILE)
+#define FW_DEFAULT 0
+
+
+/*
+** Exit codes for vmThrow
+*/
+#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
+
+/*
+** 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.
+*/
+void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
+#if FICL_WANT_FLOAT
+void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells);
+#endif
+
+/*
+** 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
+*/
+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
+
+/*
+** 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);
+
+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) && !FICL_MAIN
+#pragma warning(default: 4273)
+#endif
+
+/*
+** Ficl hash table - variable size.
+** assert(size > 0)
+** If size is 1, the table degenerates into a linked list.
+** 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
+{
+ struct ficl_hash *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;
+
+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);
+
+/*
+** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's
+** memory model. Description of fields:
+**
+** here -- points to the next free byte in the dictionary. This
+** pointer is forced to be CELL-aligned before a definition is added.
+** Do not assume any specific alignment otherwise - Use dictAlign().
+**
+** smudge -- pointer to word currently being defined (or last defined word)
+** If the definition completes successfully, the word will be
+** linked into the hash table. If unsuccessful, dictUnsmudge
+** 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".
+** 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).
+** This is the initial compilation list, and contains all
+** ficl's precompiled words.
+**
+** pCompile -- compilation wordlist - initially equal to pForthWords
+** pSearch -- 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
+** 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.
+*/
+struct ficl_dict
+{
+ 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; /* 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);
+void dictCheckThreshold(FICL_DICT* dp);
+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);
+
+
+/*
+** 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
+** 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
+** double number support to be factored cleanly.
+**
+** Each parse step is a function that receives the next input token as a STRINGINFO.
+** If the parse step matches the token, it must apply semantics to the token appropriate
+** to the present value of VM.state (compiling or interpreting), and return FICL_TRUE.
+** Otherwise it returns FICL_FALSE. See words.c: isNumber for an example
+**
+** Note: for the sake of efficiency, it's a good idea both to limit the number
+** of parse steps and to code each parse step so that it rejects tokens that
+** 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);
+
+/*
+** FICL_BREAKPOINT record.
+** origXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
+** that the breakpoint overwrote. This is restored to the dictionary when the
+** BP executes or gets cleared
+** address - the location of the breakpoint (address of the instruction that
+** has been replaced with the breakpoint trap
+** origXT - The original contents of the location with the breakpoint
+** Note: address is NULL when this breakpoint is empty
+*/
+typedef struct FICL_BREAKPOINT
+{
+ void *address;
+ FICL_WORD *origXT;
+} FICL_BREAKPOINT;
+
+
+/*
+** F I C L _ S Y S T E M
+** The top level data structure of the system - ficl_system ties a list of
+** virtual machines with their corresponding dictionaries. Ficl 3.0 will
+** support 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.
+*/
+struct ficl_system
+{
+ 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;
+
+#if FICL_WANT_LOCALS
+ FICL_WORD *pGetLocalParen;
+ FICL_WORD *pGet2LocalParen;
+ FICL_WORD *pGetLocal0;
+ FICL_WORD *pGetLocal1;
+ FICL_WORD *pToLocalParen;
+ FICL_WORD *pTo2LocalParen;
+ FICL_WORD *pToLocal0;
+ FICL_WORD *pToLocal1;
+ FICL_WORD *pLinkParen;
+ FICL_WORD *pUnLinkParen;
+ FICL_INT nLocals;
+ CELL *pMarkLocals;
+#endif
+
+ FICL_BREAKPOINT bpStep;
+};
+
+struct ficl_system_info
+{
+ int size; /* 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 */
+};
+
+
+#define ficlInitInfo(x) { memset((x), 0, sizeof(FICL_SYSTEM_INFO)); \
+ (x)->size = sizeof(FICL_SYSTEM_INFO); }
+
+/*
+** External interface to FICL...
+*/
+/*
+** f i c l I n i t S y s t e m
+** Binds a global dictionary to the interpreter system and initializes
+** the dict to contain the ANSI CORE wordset.
+** You can specify the address and size of the allocated area.
+** Using ficlInitSystemEx you can also specify the text output function.
+** After that, ficl manages it.
+** First step is to set up the static pointers to the area.
+** Then write the "precompiled" portion of the dictionary in.
+** 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);
+
+/*
+** f i c l T e r m S y s t e m
+** 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);
+
+/*
+** ficlExecFD(FICL_VM *pVM, int fd);
+ * Evaluates text from file passed in via fd.
+ * Execution returns when all of file has been executed or an
+ * error occurs.
+ */
+int ficlExecFD(FICL_VM *pVM, int fd);
+
+/*
+** Create a new VM from the heap, and link it into the system VM list.
+** Initializes the VM and binds default sized stacks to it. Returns the
+** address of the VM, or NULL if an error occurs.
+** Precondition: successful execution of ficlInitSystem
+*/
+FICL_VM *ficlNewVM(FICL_SYSTEM *pSys);
+
+/*
+** Force deletion of a VM. You do not need to do this
+** unless you're creating and discarding a lot of VMs.
+** For systems that use a constant pool of VMs for the life
+** of the system, ficltermSystem takes care of VM cleanup
+** automatically.
+*/
+void ficlFreeVM(FICL_VM *pVM);
+
+
+/*
+** 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);
+
+/*
+** 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);
+#if FICL_WANT_LOCALS
+FICL_DICT *ficlGetLoc (FICL_SYSTEM *pSys);
+#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);
+#if FICL_WANT_FLOAT
+void ficlCompileFloat(FICL_SYSTEM *pSys);
+int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ); /* float.c */
+#endif
+#if FICL_PLATFORM_EXTEND
+void ficlCompilePlatform(FICL_SYSTEM *pSys);
+#endif
+int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si);
+
+/*
+** from words.c...
+*/
+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);
+
+/*
+** 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,
+#if FICL_WANT_USER
+ USER,
+#endif
+ VARIABLE,
+} WORDKIND;
+
+WORDKIND ficlWordClassify(FICL_WORD *pFW);
+
+/*
+** Dictionary on-demand resizing
+*/
+extern CELL dictThreshold;
+extern CELL dictIncrease;
+
+/*
+** Various FreeBSD goodies
+*/
+
+#if defined(__i386__) && !defined(TESTMAIN)
+extern void ficlOutb(FICL_VM *pVM);
+extern void ficlInb(FICL_VM *pVM);
+#endif
+
+extern void ficlSetenv(FICL_VM *pVM);
+extern void ficlSetenvq(FICL_VM *pVM);
+extern void ficlGetenv(FICL_VM *pVM);
+extern void ficlUnsetenv(FICL_VM *pVM);
+extern void ficlCopyin(FICL_VM *pVM);
+extern void ficlCopyout(FICL_VM *pVM);
+extern void ficlFindfile(FICL_VM *pVM);
+extern void ficlCcall(FICL_VM *pVM);
+#if !defined(TESTMAIN)
+extern void ficlPnpdevices(FICL_VM *pVM);
+extern void ficlPnphandlers(FICL_VM *pVM);
+#endif
+
+/*
+** Used with File-Access wordset.
+*/
+#define FICL_FAM_READ 1
+#define FICL_FAM_WRITE 2
+#define FICL_FAM_APPEND 4
+#define FICL_FAM_BINARY 8
+
+#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND))
+
+
+#if (FICL_WANT_FILE)
+typedef struct ficlFILE
+{
+ FILE *f;
+ char filename[256];
+} ficlFILE;
+#endif
+
+#include <sys/linker_set.h>
+
+typedef void ficlCompileFcn(FICL_SYSTEM *);
+#define FICL_COMPILE_SET(func) \
+ DATA_SET(Xficl_compile_set, func)
+SET_DECLARE(Xficl_compile_set, ficlCompileFcn);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __FICL_H__ */
diff --git a/stand/ficl/fileaccess.c b/stand/ficl/fileaccess.c
new file mode 100644
index 0000000..2b981c8
--- /dev/null
+++ b/stand/ficl/fileaccess.c
@@ -0,0 +1,425 @@
+/* $FreeBSD$ */
+
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <sys/stat.h>
+#include "ficl.h"
+
+#if FICL_WANT_FILE
+/*
+**
+** fileaccess.c
+**
+** Implements all of the File Access word set that can be implemented in portable C.
+**
+*/
+
+static void pushIor(FICL_VM *pVM, int success)
+{
+ int ior;
+ if (success)
+ ior = 0;
+ else
+ ior = errno;
+ stackPushINT(pVM->pStack, ior);
+}
+
+
+
+static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
+{
+ int fam = stackPopINT(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+ char mode[4];
+ FILE *f;
+
+ char *filename = (char *)alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ *mode = 0;
+
+ switch (FICL_FAM_OPEN_MODE(fam))
+ {
+ case 0:
+ stackPushPtr(pVM->pStack, NULL);
+ stackPushINT(pVM->pStack, EINVAL);
+ return;
+ case FICL_FAM_READ:
+ strcat(mode, "r");
+ break;
+ case FICL_FAM_WRITE:
+ strcat(mode, writeMode);
+ break;
+ case FICL_FAM_READ | FICL_FAM_WRITE:
+ strcat(mode, writeMode);
+ strcat(mode, "+");
+ break;
+ }
+
+ strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");
+
+ f = fopen(filename, mode);
+ if (f == NULL)
+ stackPushPtr(pVM->pStack, NULL);
+ else
+ {
+ ficlFILE *ff = (ficlFILE *)malloc(sizeof(ficlFILE));
+ strcpy(ff->filename, filename);
+ ff->f = f;
+ stackPushPtr(pVM->pStack, ff);
+
+ fseek(f, 0, SEEK_SET);
+ }
+ pushIor(pVM, f != NULL);
+}
+
+
+
+static void ficlOpenFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+{
+ ficlFopen(pVM, "a");
+}
+
+
+static void ficlCreateFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
+{
+ ficlFopen(pVM, "w");
+}
+
+
+static int closeFiclFILE(ficlFILE *ff) /* ( fileid -- ior ) */
+{
+ FILE *f = ff->f;
+ free(ff);
+ return !fclose(f);
+}
+
+static void ficlCloseFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ pushIor(pVM, closeFiclFILE(ff));
+}
+
+static void ficlDeleteFile(FICL_VM *pVM) /* ( c-addr u -- ior ) */
+{
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *filename = (char *)alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ pushIor(pVM, !unlink(filename));
+}
+
+static void ficlRenameFile(FICL_VM *pVM) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
+{
+ int length;
+ void *address;
+ char *from;
+ char *to;
+
+ length = stackPopINT(pVM->pStack);
+ address = (void *)stackPopPtr(pVM->pStack);
+ to = (char *)alloca(length + 1);
+ memcpy(to, address, length);
+ to[length] = 0;
+
+ length = stackPopINT(pVM->pStack);
+ address = (void *)stackPopPtr(pVM->pStack);
+
+ from = (char *)alloca(length + 1);
+ memcpy(from, address, length);
+ from[length] = 0;
+
+ pushIor(pVM, !rename(from, to));
+}
+
+static void ficlFileStatus(FICL_VM *pVM) /* ( c-addr u -- x ior ) */
+{
+ struct stat statbuf;
+
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *filename = (char *)alloca(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ if (stat(filename, &statbuf) == 0)
+ {
+ /*
+ ** the "x" left on the stack is implementation-defined.
+ ** I push the file's access mode (readable, writeable, is directory, etc)
+ ** as defined by ANSI C.
+ */
+ stackPushINT(pVM->pStack, statbuf.st_mode);
+ stackPushINT(pVM->pStack, 0);
+ }
+ else
+ {
+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, ENOENT);
+ }
+}
+
+
+static void ficlFilePosition(FICL_VM *pVM) /* ( fileid -- ud ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ long ud = ftell(ff->f);
+ stackPushINT(pVM->pStack, ud);
+ pushIor(pVM, ud != -1);
+}
+
+
+
+static long fileSize(FILE *f)
+{
+ struct stat statbuf;
+ statbuf.st_size = -1;
+ if (fstat(fileno(f), &statbuf) != 0)
+ return -1;
+ return statbuf.st_size;
+}
+
+
+
+static void ficlFileSize(FICL_VM *pVM) /* ( fileid -- ud ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ long ud = fileSize(ff->f);
+ stackPushINT(pVM->pStack, ud);
+ pushIor(pVM, ud != -1);
+}
+
+
+
+#define nLINEBUF 256
+static void ficlIncludeFile(FICL_VM *pVM) /* ( i*x fileid -- j*x ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ CELL id = pVM->sourceID;
+ int result = VM_OUTOFTEXT;
+ long currentPosition, totalSize;
+ long size;
+ pVM->sourceID.p = (void *)ff;
+
+ currentPosition = ftell(ff->f);
+ totalSize = fileSize(ff->f);
+ size = totalSize - currentPosition;
+
+ if ((totalSize != -1) && (currentPosition != -1) && (size > 0))
+ {
+ char *buffer = (char *)malloc(size);
+ long got = fread(buffer, 1, size, ff->f);
+ if (got == size)
+ result = ficlExecC(pVM, buffer, size);
+ }
+
+#if 0
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ CELL id = pVM->sourceID;
+ char cp[nLINEBUF];
+ int nLine = 0;
+ int keepGoing;
+ int result;
+ pVM->sourceID.p = (void *)ff;
+
+ /* feed each line to ficlExec */
+ keepGoing = TRUE;
+ while (keepGoing && fgets(cp, nLINEBUF, ff->f))
+ {
+ int len = strlen(cp) - 1;
+
+ nLine++;
+ if (len <= 0)
+ continue;
+
+ if (cp[len] == '\n')
+ cp[len] = '\0';
+
+ result = ficlExec(pVM, cp);
+
+ switch (result)
+ {
+ case VM_OUTOFTEXT:
+ case VM_USEREXIT:
+ break;
+
+ default:
+ pVM->sourceID = id;
+ keepGoing = FALSE;
+ break;
+ }
+ }
+#endif /* 0 */
+ /*
+ ** Pass an empty line with SOURCE-ID == -1 to flush
+ ** any pending REFILLs (as required by FILE wordset)
+ */
+ pVM->sourceID.i = -1;
+ ficlExec(pVM, "");
+
+ pVM->sourceID = id;
+ closeFiclFILE(ff);
+}
+
+
+
+static void ficlReadFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+ int result;
+
+ clearerr(ff->f);
+ result = fread(address, 1, length, ff->f);
+
+ stackPushINT(pVM->pStack, result);
+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ char *address = (char *)stackPopPtr(pVM->pStack);
+ int error;
+ int flag;
+
+ if (feof(ff->f))
+ {
+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, 0);
+ stackPushINT(pVM->pStack, 0);
+ return;
+ }
+
+ clearerr(ff->f);
+ *address = 0;
+ fgets(address, length, ff->f);
+
+ error = ferror(ff->f);
+ if (error != 0)
+ {
+ stackPushINT(pVM->pStack, -1);
+ stackPushINT(pVM->pStack, 0);
+ stackPushINT(pVM->pStack, error);
+ return;
+ }
+
+ length = strlen(address);
+ flag = (length > 0);
+ if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
+ length--;
+
+ stackPushINT(pVM->pStack, length);
+ stackPushINT(pVM->pStack, flag);
+ stackPushINT(pVM->pStack, 0); /* ior */
+}
+
+
+
+static void ficlWriteFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ clearerr(ff->f);
+ fwrite(address, 1, length, ff->f);
+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlWriteLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t length = (size_t)stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ clearerr(ff->f);
+ if (fwrite(address, 1, length, ff->f) == length)
+ fwrite("\n", 1, 1, ff->f);
+ pushIor(pVM, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlRepositionFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t ud = (size_t)stackPopINT(pVM->pStack);
+
+ pushIor(pVM, fseek(ff->f, ud, SEEK_SET) == 0);
+}
+
+
+
+static void ficlFlushFile(FICL_VM *pVM) /* ( fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ pushIor(pVM, fflush(ff->f) == 0);
+}
+
+
+
+#if FICL_HAVE_FTRUNCATE
+
+static void ficlResizeFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
+{
+ ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
+ size_t ud = (size_t)stackPopINT(pVM->pStack);
+
+ pushIor(pVM, ftruncate(fileno(ff->f), ud) == 0);
+}
+
+#endif /* FICL_HAVE_FTRUNCATE */
+
+#endif /* FICL_WANT_FILE */
+
+
+
+void ficlCompileFile(FICL_SYSTEM *pSys)
+{
+#if FICL_WANT_FILE
+ FICL_DICT *dp = pSys->dp;
+ assert(dp);
+
+ dictAppendWord(dp, "create-file", ficlCreateFile, FW_DEFAULT);
+ dictAppendWord(dp, "open-file", ficlOpenFile, FW_DEFAULT);
+ dictAppendWord(dp, "close-file", ficlCloseFile, FW_DEFAULT);
+ dictAppendWord(dp, "include-file", ficlIncludeFile, FW_DEFAULT);
+ dictAppendWord(dp, "read-file", ficlReadFile, FW_DEFAULT);
+ dictAppendWord(dp, "read-line", ficlReadLine, FW_DEFAULT);
+ dictAppendWord(dp, "write-file", ficlWriteFile, FW_DEFAULT);
+ dictAppendWord(dp, "write-line", ficlWriteLine, FW_DEFAULT);
+ dictAppendWord(dp, "file-position", ficlFilePosition, FW_DEFAULT);
+ dictAppendWord(dp, "file-size", ficlFileSize, FW_DEFAULT);
+ dictAppendWord(dp, "reposition-file", ficlRepositionFile, FW_DEFAULT);
+ dictAppendWord(dp, "file-status", ficlFileStatus, FW_DEFAULT);
+ dictAppendWord(dp, "flush-file", ficlFlushFile, FW_DEFAULT);
+
+ dictAppendWord(dp, "delete-file", ficlDeleteFile, FW_DEFAULT);
+ dictAppendWord(dp, "rename-file", ficlRenameFile, FW_DEFAULT);
+
+#ifdef FICL_HAVE_FTRUNCATE
+ dictAppendWord(dp, "resize-file", ficlResizeFile, FW_DEFAULT);
+
+ ficlSetEnv(pSys, "file", FICL_TRUE);
+ ficlSetEnv(pSys, "file-ext", FICL_TRUE);
+#endif /* FICL_HAVE_FTRUNCATE */
+#else
+ (void)pSys;
+#endif /* FICL_WANT_FILE */
+}
diff --git a/stand/ficl/float.c b/stand/ficl/float.c
new file mode 100644
index 0000000..d757b23
--- /dev/null
+++ b/stand/ficl/float.c
@@ -0,0 +1,1067 @@
+/*******************************************************************
+** f l o a t . c
+** Forth Inspired Command Language
+** 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/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include "ficl.h"
+
+#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 )
+*******************************************************************/
+static void Fsub(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 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)
+{
+ FICL_FLOAT f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+#endif
+
+ f = -GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** 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)
+{
+ 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 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)
+{
+ 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 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)
+{
+ 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 / 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)
+{
+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+ vmCheckFStack(pVM, 0, 1);
+#endif
+
+ f = (float)POPINT();
+ PUSHFLOAT(f);
+}
+
+/*******************************************************************
+** 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)
+{
+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ f = POPFLOAT();
+ sprintf(pVM->pad,"%#f ",f);
+ vmTextOut(pVM, pVM->pad, 0);
+}
+
+/*******************************************************************
+** Display a float in engineering format.
+** fe. ( r -- )
+*******************************************************************/
+static void EDot(FICL_VM *pVM)
+{
+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ f = POPFLOAT();
+ sprintf(pVM->pad,"%#e ",f);
+ vmTextOut(pVM, pVM->pad, 0);
+}
+
+/**************************************************************************
+ d i s p l a y FS t a c k
+** 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)
+{
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 3, 3);
+#endif
+
+ ROLLF(-2);
+}
+
+/*******************************************************************
+** Do float stack swap.
+** fswap ( r1 r2 -- r2 r1 )
+*******************************************************************/
+static void Fswap(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 2);
+#endif
+
+ ROLLF(1);
+}
+
+/*******************************************************************
+** 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)
+{
+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 0, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ pCell = (CELL *)POPPTR();
+ PUSHFLOAT(pCell->f);
+}
+
+/*******************************************************************
+** 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 -- )
+*******************************************************************/
+static void FplusStore(FICL_VM *pVM)
+{
+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ pCell = (CELL *)POPPTR();
+ pCell->f += POPFLOAT();
+}
+
+/*******************************************************************
+** Floating point literal execution word.
+*******************************************************************/
+static void fliteralParen(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ PUSHFLOAT(*(float*)(pVM->ip));
+ vmBranchRelative(pVM, 1);
+}
+
+/*******************************************************************
+** Compile a floating point literal.
+*******************************************************************/
+static void fliteralIm(FICL_VM *pVM)
+{
+ FICL_DICT *dp = vmGetDict(pVM);
+ FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)");
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
+ dictAppendCell(dp, stackPop(pVM->fStack));
+}
+
+/*******************************************************************
+** 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));
+}
+
+/*******************************************************************
+** 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
+** being parsed.
+**************************************************************************/
+#define NUMISNEG 1
+#define EXPISNEG 2
+
+typedef enum _floatParseState
+{
+ FPS_START,
+ FPS_ININT,
+ FPS_INMANT,
+ FPS_STARTEXP,
+ FPS_INEXP
+} 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.
+** Returns 1 if successful, 0 if not.
+**************************************************************************/
+int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
+{
+ unsigned char ch, digit;
+ char *cp;
+ FICL_COUNT count;
+ float power;
+ float accum = 0.0f;
+ float mant = 0.1f;
+ FICL_INT exponent = 0;
+ char flag = 0;
+ FloatParseState estate = FPS_START;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 0, 1);
+#endif
+
+ /*
+ ** floating point numbers only allowed in base 10
+ */
+ if (pVM->base != 10)
+ return(0);
+
+
+ cp = SI_PTR(si);
+ count = (FICL_COUNT)SI_COUNT(si);
+
+ /* Loop through the string's characters. */
+ while ((count--) && ((ch = *cp++) != 0))
+ {
+ switch (estate)
+ {
+ /* At start of the number so look for a sign. */
+ case FPS_START:
+ {
+ estate = FPS_ININT;
+ if (ch == '-')
+ {
+ flag |= NUMISNEG;
+ break;
+ }
+ if (ch == '+')
+ {
+ break;
+ }
+ } /* Note! Drop through to FPS_ININT */
+ /*
+ **Converting integer part of number.
+ ** Only allow digits, decimal and 'E'.
+ */
+ case FPS_ININT:
+ {
+ if (ch == '.')
+ {
+ estate = FPS_INMANT;
+ }
+ else if ((ch == 'e') || (ch == 'E'))
+ {
+ estate = FPS_STARTEXP;
+ }
+ else
+ {
+ digit = (unsigned char)(ch - '0');
+ if (digit > 9)
+ return(0);
+
+ accum = accum * 10 + digit;
+
+ }
+ break;
+ }
+ /*
+ ** Processing the fraction part of number.
+ ** Only allow digits and 'E'
+ */
+ case FPS_INMANT:
+ {
+ if ((ch == 'e') || (ch == 'E'))
+ {
+ estate = FPS_STARTEXP;
+ }
+ else
+ {
+ digit = (unsigned char)(ch - '0');
+ if (digit > 9)
+ return(0);
+
+ accum += digit * mant;
+ mant *= 0.1f;
+ }
+ break;
+ }
+ /* Start processing the exponent part of number. */
+ /* Look for sign. */
+ case FPS_STARTEXP:
+ {
+ estate = FPS_INEXP;
+
+ if (ch == '-')
+ {
+ flag |= EXPISNEG;
+ break;
+ }
+ else if (ch == '+')
+ {
+ break;
+ }
+ } /* Note! Drop through to FPS_INEXP */
+ /*
+ ** Processing the exponent part of number.
+ ** Only allow digits.
+ */
+ case FPS_INEXP:
+ {
+ digit = (unsigned char)(ch - '0');
+ if (digit > 9)
+ return(0);
+
+ exponent = exponent * 10 + digit;
+
+ break;
+ }
+ }
+ }
+
+ /* If parser never made it to the exponent this is not a float. */
+ if (estate < FPS_STARTEXP)
+ return(0);
+
+ /* Set the sign of the number. */
+ if (flag & NUMISNEG)
+ accum = -accum;
+
+ /* If exponent is not 0 then adjust number by it. */
+ if (exponent != 0)
+ {
+ /* Determine if exponent is negative. */
+ if (flag & EXPISNEG)
+ {
+ exponent = -exponent;
+ }
+ /* power = 10^x */
+ power = (float)pow(10.0, exponent);
+ accum *= power;
+ }
+
+ PUSHFLOAT(accum);
+ if (pVM->state == COMPILE)
+ fliteralIm(pVM);
+
+ return(1);
+}
+
+#endif /* FICL_WANT_FLOAT */
+
+/**************************************************************************
+** Add float words to a system's dictionary.
+** pSys -- Pointer to the FICL sytem to add float words to.
+**************************************************************************/
+void ficlCompileFloat(FICL_SYSTEM *pSys)
+{
+ 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);
+ /*
+ 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);
+#endif
+ return;
+}
+
diff --git a/stand/ficl/i386/sysdep.c b/stand/ficl/i386/sysdep.c
new file mode 100644
index 0000000..ea594e6
--- /dev/null
+++ b/stand/ficl/i386/sysdep.c
@@ -0,0 +1,149 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#ifdef __i386__
+#include <machine/cpufunc.h>
+#endif
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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((unsigned char)*(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);
+}
+
+#ifndef TESTMAIN
+/*
+ * outb ( port# c -- )
+ * Store a byte to I/O port number port#
+ */
+void
+ficlOutb(FICL_VM *pVM)
+{
+ u_char c;
+ u_int32_t port;
+
+ port=stackPopUNS(pVM->pStack);
+ c=(u_char)stackPopINT(pVM->pStack);
+ outb(port,c);
+}
+
+/*
+ * inb ( port# -- c )
+ * Fetch a byte from I/O port number port#
+ */
+void
+ficlInb(FICL_VM *pVM)
+{
+ u_char c;
+ u_int32_t port;
+
+ port=stackPopUNS(pVM->pStack);
+ c=inb(port);
+ stackPushINT(pVM->pStack,c);
+}
+
+/*
+ * Glue function to add the appropriate forth words to access x86 special cpu
+ * functionality.
+ */
+static void ficlCompileCpufunc(FICL_SYSTEM *pSys)
+{
+ FICL_DICT *dp = pSys->dp;
+ assert (dp);
+
+ dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT);
+ dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT);
+}
+
+FICL_COMPILE_SET(ficlCompileCpufunc);
+
+#endif
+
+/*
+** 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 */
diff --git a/stand/ficl/i386/sysdep.h b/stand/ficl/i386/sysdep.h
new file mode 100644
index 0000000..94fda20
--- /dev/null
+++ b/stand/ficl/i386/sysdep.h
@@ -0,0 +1,432 @@
+/*******************************************************************
+ 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/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#if !defined IGNORE /* Macro to silence unused param warnings */
+#define IGNORE(x) (void)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
+
+/*
+** 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
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#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 260
+#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) /* 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/stand/ficl/loader.c b/stand/ficl/loader.c
new file mode 100644
index 0000000..2246190
--- /dev/null
+++ b/stand/ficl/loader.c
@@ -0,0 +1,841 @@
+/*-
+ * Copyright (c) 2000 Daniel Capo Sobral
+ * All rights reserved.
+ *
+ * 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.
+ *
+ * $FreeBSD$
+ */
+
+/*******************************************************************
+** l o a d e r . c
+** Additional FICL words designed for FreeBSD's loader
+**
+*******************************************************************/
+
+#ifdef TESTMAIN
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <dirent.h>
+#include <fcntl.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#else
+#include <stand.h>
+#endif
+#include "bootstrap.h"
+#include <string.h>
+#include <uuid.h>
+#include "ficl.h"
+
+/* FreeBSD's loader interaction words and extras
+ *
+ * setenv ( value n name n' -- )
+ * setenv? ( value n name n' flag -- )
+ * getenv ( addr n -- addr' n' | -1 )
+ * unsetenv ( addr n -- )
+ * copyin ( addr addr' len -- )
+ * copyout ( addr addr' len -- )
+ * findfile ( name len type len' -- addr )
+ * pnpdevices ( -- addr )
+ * pnphandlers ( -- addr )
+ * ccall ( [[...[p10] p9] ... p1] n addr -- result )
+ * uuid-from-string ( addr n -- addr' )
+ * uuid-to-string ( addr' -- addr n )
+ * .# ( value -- )
+ */
+
+void
+ficlSetenv(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *name, *value;
+#endif
+ char *namep, *valuep;
+ int names, values;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 4, 0);
+#endif
+ names = stackPopINT(pVM->pStack);
+ namep = (char*) stackPopPtr(pVM->pStack);
+ values = stackPopINT(pVM->pStack);
+ valuep = (char*) stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ name = (char*) ficlMalloc(names+1);
+ if (!name)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(name, namep, names);
+ name[names] = '\0';
+ value = (char*) ficlMalloc(values+1);
+ if (!value)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(value, valuep, values);
+ value[values] = '\0';
+
+ setenv(name, value, 1);
+ ficlFree(name);
+ ficlFree(value);
+#endif
+
+ return;
+}
+
+void
+ficlSetenvq(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *name, *value;
+#endif
+ char *namep, *valuep;
+ int names, values, overwrite;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 5, 0);
+#endif
+ overwrite = stackPopINT(pVM->pStack);
+ names = stackPopINT(pVM->pStack);
+ namep = (char*) stackPopPtr(pVM->pStack);
+ values = stackPopINT(pVM->pStack);
+ valuep = (char*) stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ name = (char*) ficlMalloc(names+1);
+ if (!name)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(name, namep, names);
+ name[names] = '\0';
+ value = (char*) ficlMalloc(values+1);
+ if (!value)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(value, valuep, values);
+ value[values] = '\0';
+
+ setenv(name, value, overwrite);
+ ficlFree(name);
+ ficlFree(value);
+#endif
+
+ return;
+}
+
+void
+ficlGetenv(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *name, *value;
+#endif
+ char *namep;
+ int names;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 2);
+#endif
+ names = stackPopINT(pVM->pStack);
+ namep = (char*) stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ name = (char*) ficlMalloc(names+1);
+ if (!name)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(name, namep, names);
+ name[names] = '\0';
+
+ value = getenv(name);
+ ficlFree(name);
+
+ if(value != NULL) {
+ stackPushPtr(pVM->pStack, value);
+ stackPushINT(pVM->pStack, strlen(value));
+ } else
+#endif
+ stackPushINT(pVM->pStack, -1);
+
+ return;
+}
+
+void
+ficlUnsetenv(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *name;
+#endif
+ char *namep;
+ int names;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+ names = stackPopINT(pVM->pStack);
+ namep = (char*) stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ name = (char*) ficlMalloc(names+1);
+ if (!name)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(name, namep, names);
+ name[names] = '\0';
+
+ unsetenv(name);
+ ficlFree(name);
+#endif
+
+ return;
+}
+
+void
+ficlCopyin(FICL_VM *pVM)
+{
+ void* src;
+ vm_offset_t dest;
+ size_t len;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 0);
+#endif
+
+ len = stackPopINT(pVM->pStack);
+ dest = stackPopINT(pVM->pStack);
+ src = stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ archsw.arch_copyin(src, dest, len);
+#endif
+
+ return;
+}
+
+void
+ficlCopyout(FICL_VM *pVM)
+{
+ void* dest;
+ vm_offset_t src;
+ size_t len;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 0);
+#endif
+
+ len = stackPopINT(pVM->pStack);
+ dest = stackPopPtr(pVM->pStack);
+ src = stackPopINT(pVM->pStack);
+
+#ifndef TESTMAIN
+ archsw.arch_copyout(src, dest, len);
+#endif
+
+ return;
+}
+
+void
+ficlFindfile(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *name, *type;
+#endif
+ char *namep, *typep;
+ struct preloaded_file* fp;
+ int names, types;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 4, 1);
+#endif
+
+ types = stackPopINT(pVM->pStack);
+ typep = (char*) stackPopPtr(pVM->pStack);
+ names = stackPopINT(pVM->pStack);
+ namep = (char*) stackPopPtr(pVM->pStack);
+#ifndef TESTMAIN
+ name = (char*) ficlMalloc(names+1);
+ if (!name)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(name, namep, names);
+ name[names] = '\0';
+ type = (char*) ficlMalloc(types+1);
+ if (!type)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(type, typep, types);
+ type[types] = '\0';
+
+ fp = file_findfile(name, type);
+#else
+ fp = NULL;
+#endif
+ stackPushPtr(pVM->pStack, fp);
+
+ return;
+}
+
+void
+ficlCcall(FICL_VM *pVM)
+{
+ int (*func)(int, ...);
+ int result, p[10];
+ int nparam, i;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+
+ func = stackPopPtr(pVM->pStack);
+ nparam = stackPopINT(pVM->pStack);
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, nparam, 1);
+#endif
+
+ for (i = 0; i < nparam; i++)
+ p[i] = stackPopINT(pVM->pStack);
+
+ result = func(p[0], p[1], p[2], p[3], p[4], p[5], p[6], p[7], p[8],
+ p[9]);
+
+ stackPushINT(pVM->pStack, result);
+
+ return;
+}
+
+void
+ficlUuidFromString(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *uuid;
+ uint32_t status;
+#endif
+ char *uuidp;
+ int uuids;
+ uuid_t *u;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+
+ uuids = stackPopINT(pVM->pStack);
+ uuidp = (char *) stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ uuid = (char *)ficlMalloc(uuids + 1);
+ if (!uuid)
+ vmThrowErr(pVM, "Error: out of memory");
+ strncpy(uuid, uuidp, uuids);
+ uuid[uuids] = '\0';
+
+ u = (uuid_t *)ficlMalloc(sizeof (*u));
+
+ uuid_from_string(uuid, u, &status);
+ ficlFree(uuid);
+ if (status != uuid_s_ok) {
+ ficlFree(u);
+ u = NULL;
+ }
+#else
+ u = NULL;
+#endif
+ stackPushPtr(pVM->pStack, u);
+
+
+ return;
+}
+
+void
+ficlUuidToString(FICL_VM *pVM)
+{
+#ifndef TESTMAIN
+ char *uuid;
+ uint32_t status;
+#endif
+ uuid_t *u;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ u = (uuid_t *)stackPopPtr(pVM->pStack);
+
+#ifndef TESTMAIN
+ uuid_to_string(u, &uuid, &status);
+ if (status != uuid_s_ok) {
+ stackPushPtr(pVM->pStack, uuid);
+ stackPushINT(pVM->pStack, strlen(uuid));
+ } else
+#endif
+ stackPushINT(pVM->pStack, -1);
+
+ return;
+}
+
+/**************************************************************************
+ f i c l E x e c F D
+** reads in text from file fd and passes it to ficlExec()
+ * returns VM_OUTOFTEXT on success or the ficlExec() error code on
+ * failure.
+ */
+#define nLINEBUF 256
+int ficlExecFD(FICL_VM *pVM, int fd)
+{
+ char cp[nLINEBUF];
+ int nLine = 0, rval = VM_OUTOFTEXT;
+ char ch;
+ CELL id;
+
+ id = pVM->sourceID;
+ pVM->sourceID.i = fd;
+
+ /* feed each line to ficlExec */
+ while (1) {
+ int status, i;
+
+ i = 0;
+ while ((status = read(fd, &ch, 1)) > 0 && ch != '\n')
+ cp[i++] = ch;
+ nLine++;
+ if (!i) {
+ if (status < 1)
+ break;
+ continue;
+ }
+ rval = ficlExecC(pVM, cp, i);
+ if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT)
+ {
+ pVM->sourceID = id;
+ return rval;
+ }
+ }
+ /*
+ ** 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;
+ return rval;
+}
+
+static void displayCellNoPad(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);
+ vmTextOut(pVM, pVM->pad, 0);
+ return;
+}
+
+/* isdir? - Return whether an fd corresponds to a directory.
+ *
+ * isdir? ( fd -- bool )
+ */
+static void isdirQuestion(FICL_VM *pVM)
+{
+ struct stat sb;
+ FICL_INT flag;
+ int fd;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+
+ fd = stackPopINT(pVM->pStack);
+ flag = FICL_FALSE;
+ do {
+ if (fd < 0)
+ break;
+ if (fstat(fd, &sb) < 0)
+ break;
+ if (!S_ISDIR(sb.st_mode))
+ break;
+ flag = FICL_TRUE;
+ } while (0);
+ stackPushINT(pVM->pStack, flag);
+}
+
+/* fopen - open a file and return new fd on stack.
+ *
+ * fopen ( ptr count mode -- fd )
+ */
+static void pfopen(FICL_VM *pVM)
+{
+ int mode, fd, count;
+ char *ptr, *name;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 1);
+#endif
+
+ mode = stackPopINT(pVM->pStack); /* get mode */
+ count = stackPopINT(pVM->pStack); /* get count */
+ ptr = stackPopPtr(pVM->pStack); /* get ptr */
+
+ if ((count < 0) || (ptr == NULL)) {
+ stackPushINT(pVM->pStack, -1);
+ return;
+ }
+
+ /* ensure that the string is null terminated */
+ name = (char *)malloc(count+1);
+ bcopy(ptr,name,count);
+ name[count] = 0;
+
+ /* open the file */
+ fd = open(name, mode);
+ free(name);
+ stackPushINT(pVM->pStack, fd);
+ return;
+}
+
+/* fclose - close a file who's fd is on stack.
+ *
+ * fclose ( fd -- )
+ */
+static void pfclose(FICL_VM *pVM)
+{
+ int fd;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ fd = stackPopINT(pVM->pStack); /* get fd */
+ if (fd != -1)
+ close(fd);
+ return;
+}
+
+/* fread - read file contents
+ *
+ * fread ( fd buf nbytes -- nread )
+ */
+static void pfread(FICL_VM *pVM)
+{
+ int fd, len;
+ char *buf;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 1);
+#endif
+ len = stackPopINT(pVM->pStack); /* get number of bytes to read */
+ buf = stackPopPtr(pVM->pStack); /* get buffer */
+ fd = stackPopINT(pVM->pStack); /* get fd */
+ if (len > 0 && buf && fd != -1)
+ stackPushINT(pVM->pStack, read(fd, buf, len));
+ else
+ stackPushINT(pVM->pStack, -1);
+ return;
+}
+
+/* freaddir - read directory contents
+ *
+ * freaddir ( fd -- ptr len TRUE | FALSE )
+ */
+static void pfreaddir(FICL_VM *pVM)
+{
+#ifdef TESTMAIN
+ static struct dirent dirent;
+ struct stat sb;
+ char *buf;
+ off_t off, ptr;
+ u_int blksz;
+ int bufsz;
+#endif
+ struct dirent *d;
+ int fd;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 3);
+#endif
+
+ fd = stackPopINT(pVM->pStack);
+#if TESTMAIN
+ /*
+ * The readdirfd() function is specific to the loader environment.
+ * We do the best we can to make freaddir work, but it's not at
+ * all guaranteed.
+ */
+ d = NULL;
+ buf = NULL;
+ do {
+ if (fd == -1)
+ break;
+ if (fstat(fd, &sb) == -1)
+ break;
+ blksz = (sb.st_blksize) ? sb.st_blksize : getpagesize();
+ if ((blksz & (blksz - 1)) != 0)
+ break;
+ buf = malloc(blksz);
+ if (buf == NULL)
+ break;
+ off = lseek(fd, 0LL, SEEK_CUR);
+ if (off == -1)
+ break;
+ ptr = off;
+ if (lseek(fd, 0, SEEK_SET) == -1)
+ break;
+ bufsz = getdents(fd, buf, blksz);
+ while (bufsz > 0 && bufsz <= ptr) {
+ ptr -= bufsz;
+ bufsz = getdents(fd, buf, blksz);
+ }
+ if (bufsz <= 0)
+ break;
+ d = (void *)(buf + ptr);
+ dirent = *d;
+ off += d->d_reclen;
+ d = (lseek(fd, off, SEEK_SET) != off) ? NULL : &dirent;
+ } while (0);
+ if (buf != NULL)
+ free(buf);
+#else
+ d = readdirfd(fd);
+#endif
+ if (d != NULL) {
+ stackPushPtr(pVM->pStack, d->d_name);
+ stackPushINT(pVM->pStack, strlen(d->d_name));
+ stackPushINT(pVM->pStack, FICL_TRUE);
+ } else {
+ stackPushINT(pVM->pStack, FICL_FALSE);
+ }
+}
+
+/* fload - interpret file contents
+ *
+ * fload ( fd -- )
+ */
+static void pfload(FICL_VM *pVM)
+{
+ int fd;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ fd = stackPopINT(pVM->pStack); /* get fd */
+ if (fd != -1)
+ ficlExecFD(pVM, fd);
+ return;
+}
+
+/* fwrite - write file contents
+ *
+ * fwrite ( fd buf nbytes -- nwritten )
+ */
+static void pfwrite(FICL_VM *pVM)
+{
+ int fd, len;
+ char *buf;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 1);
+#endif
+ len = stackPopINT(pVM->pStack); /* get number of bytes to read */
+ buf = stackPopPtr(pVM->pStack); /* get buffer */
+ fd = stackPopINT(pVM->pStack); /* get fd */
+ if (len > 0 && buf && fd != -1)
+ stackPushINT(pVM->pStack, write(fd, buf, len));
+ else
+ stackPushINT(pVM->pStack, -1);
+ return;
+}
+
+/* fseek - seek to a new position in a file
+ *
+ * fseek ( fd ofs whence -- pos )
+ */
+static void pfseek(FICL_VM *pVM)
+{
+ int fd, pos, whence;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 3, 1);
+#endif
+ whence = stackPopINT(pVM->pStack);
+ pos = stackPopINT(pVM->pStack);
+ fd = stackPopINT(pVM->pStack);
+ stackPushINT(pVM->pStack, lseek(fd, pos, whence));
+ return;
+}
+
+/* key - get a character from stdin
+ *
+ * key ( -- char )
+ */
+static void key(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+ stackPushINT(pVM->pStack, getchar());
+ return;
+}
+
+/* key? - check for a character from stdin (FACILITY)
+ *
+ * key? ( -- flag )
+ */
+static void keyQuestion(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+#ifdef TESTMAIN
+ /* XXX Since we don't fiddle with termios, let it always succeed... */
+ stackPushINT(pVM->pStack, FICL_TRUE);
+#else
+ /* But here do the right thing. */
+ stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
+#endif
+ return;
+}
+
+/* seconds - gives number of seconds since beginning of time
+ *
+ * beginning of time is defined as:
+ *
+ * BTX - number of seconds since midnight
+ * FreeBSD - number of seconds since Jan 1 1970
+ *
+ * seconds ( -- u )
+ */
+static void pseconds(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,0,1);
+#endif
+ stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL));
+ return;
+}
+
+/* ms - wait at least that many milliseconds (FACILITY)
+ *
+ * ms ( u -- )
+ *
+ */
+static void ms(FICL_VM *pVM)
+{
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,0);
+#endif
+#ifdef TESTMAIN
+ usleep(stackPopUNS(pVM->pStack)*1000);
+#else
+ delay(stackPopUNS(pVM->pStack)*1000);
+#endif
+ return;
+}
+
+/* fkey - get a character from a file
+ *
+ * fkey ( file -- char )
+ */
+static void fkey(FICL_VM *pVM)
+{
+ int i, fd;
+ char ch;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ fd = stackPopINT(pVM->pStack);
+ i = read(fd, &ch, 1);
+ stackPushINT(pVM->pStack, i > 0 ? ch : -1);
+ return;
+}
+
+
+/*
+** Retrieves free space remaining on the dictionary
+*/
+
+static void freeHeap(FICL_VM *pVM)
+{
+ stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict(pVM->pSys)));
+}
+
+
+/******************* Increase dictionary size on-demand ******************/
+
+static void ficlDictThreshold(FICL_VM *pVM)
+{
+ stackPushPtr(pVM->pStack, &dictThreshold);
+}
+
+static void ficlDictIncrease(FICL_VM *pVM)
+{
+ stackPushPtr(pVM->pStack, &dictIncrease);
+}
+
+/**************************************************************************
+ f i c l C o m p i l e P l a t f o r m
+** Build FreeBSD platform extensions into the system dictionary
+**************************************************************************/
+void ficlCompilePlatform(FICL_SYSTEM *pSys)
+{
+ ficlCompileFcn **fnpp;
+ FICL_DICT *dp = pSys->dp;
+ assert (dp);
+
+ dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT);
+ dictAppendWord(dp, "isdir?", isdirQuestion, FW_DEFAULT);
+ dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT);
+ dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT);
+ dictAppendWord(dp, "fread", pfread, FW_DEFAULT);
+ dictAppendWord(dp, "freaddir", pfreaddir, FW_DEFAULT);
+ dictAppendWord(dp, "fload", pfload, FW_DEFAULT);
+ dictAppendWord(dp, "fkey", fkey, FW_DEFAULT);
+ dictAppendWord(dp, "fseek", pfseek, FW_DEFAULT);
+ dictAppendWord(dp, "fwrite", pfwrite, FW_DEFAULT);
+ dictAppendWord(dp, "key", key, FW_DEFAULT);
+ dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT);
+ dictAppendWord(dp, "ms", ms, FW_DEFAULT);
+ dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT);
+ dictAppendWord(dp, "heap?", freeHeap, FW_DEFAULT);
+ dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT);
+ dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT);
+
+ dictAppendWord(dp, "setenv", ficlSetenv, FW_DEFAULT);
+ dictAppendWord(dp, "setenv?", ficlSetenvq, FW_DEFAULT);
+ dictAppendWord(dp, "getenv", ficlGetenv, FW_DEFAULT);
+ dictAppendWord(dp, "unsetenv", ficlUnsetenv, FW_DEFAULT);
+ dictAppendWord(dp, "copyin", ficlCopyin, FW_DEFAULT);
+ dictAppendWord(dp, "copyout", ficlCopyout, FW_DEFAULT);
+ dictAppendWord(dp, "findfile", ficlFindfile, FW_DEFAULT);
+ dictAppendWord(dp, "ccall", ficlCcall, FW_DEFAULT);
+ dictAppendWord(dp, "uuid-from-string", ficlUuidFromString, FW_DEFAULT);
+ dictAppendWord(dp, "uuid-to-string", ficlUuidToString, FW_DEFAULT);
+
+ SET_FOREACH(fnpp, Xficl_compile_set)
+ (*fnpp)(pSys);
+
+#if defined(PC98)
+ ficlSetEnv(pSys, "arch-pc98", FICL_TRUE);
+#elif defined(__i386__)
+ ficlSetEnv(pSys, "arch-i386", FICL_TRUE);
+ ficlSetEnv(pSys, "arch-powerpc", FICL_FALSE);
+#elif defined(__powerpc__)
+ ficlSetEnv(pSys, "arch-i386", FICL_FALSE);
+ ficlSetEnv(pSys, "arch-powerpc", FICL_TRUE);
+#endif
+
+ return;
+}
diff --git a/stand/ficl/math64.c b/stand/ficl/math64.c
new file mode 100644
index 0000000..6e50458
--- /dev/null
+++ b/stand/ficl/math64.c
@@ -0,0 +1,561 @@
+/*******************************************************************
+** 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.9 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#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/stand/ficl/math64.h b/stand/ficl/math64.h
new file mode 100644
index 0000000..a4e5636
--- /dev/null
+++ b/stand/ficl/math64.h
@@ -0,0 +1,88 @@
+/*******************************************************************
+** 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.9 2001/12/05 07:21:34 jsadler Exp $
+*******************************************************************/
+/*
+** 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.
+*/
+
+/* $FreeBSD$ */
+
+#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/stand/ficl/mips/sysdep.c b/stand/ficl/mips/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/mips/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/mips/sysdep.h b/stand/ficl/mips/sysdep.h
new file mode 100644
index 0000000..3ae748e
--- /dev/null
+++ b/stand/ficl/mips/sysdep.h
@@ -0,0 +1,432 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 1
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_PLATFORM_EXTEND
+** Includes words defined in ficlCompilePlatform
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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/stand/ficl/mips64/sysdep.c b/stand/ficl/mips64/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/mips64/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/mips64/sysdep.h b/stand/ficl/mips64/sysdep.h
new file mode 100644
index 0000000..5c9e163
--- /dev/null
+++ b/stand/ficl/mips64/sysdep.h
@@ -0,0 +1,432 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 long
+#endif
+
+#if !defined FICL_UNS
+#define FICL_UNS unsigned long
+#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 64
+#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 1
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_PLATFORM_EXTEND
+** Includes words defined in ficlCompilePlatform
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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 3
+#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/stand/ficl/powerpc/sysdep.c b/stand/ficl/powerpc/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/powerpc/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/powerpc/sysdep.h b/stand/ficl/powerpc/sysdep.h
new file mode 100644
index 0000000..3ae748e
--- /dev/null
+++ b/stand/ficl/powerpc/sysdep.h
@@ -0,0 +1,432 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 1
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_PLATFORM_EXTEND
+** Includes words defined in ficlCompilePlatform
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 1
+#endif
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
+** have a filesystem!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE 0
+#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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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/stand/ficl/prefix.c b/stand/ficl/prefix.c
new file mode 100644
index 0000000..a34fc6c
--- /dev/null
+++ b/stand/ficl/prefix.c
@@ -0,0 +1,199 @@
+/*******************************************************************
+** p r e f i x . c
+** Forth Inspired Command Language
+** Parser extensions for Ficl
+** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu)
+** Created: April 2001
+** $Id: prefix.c,v 1.6 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+#include "math64.h"
+
+/*
+** (jws) revisions:
+** A prefix is a word in a dedicated wordlist (name stored in list_name below)
+** that is searched in a special way by the prefix parse step. When a prefix
+** matches the beginning of an incoming token, push the non-prefix part of the
+** token back onto the input stream and execute the prefix code.
+**
+** The parse step is called ficlParsePrefix.
+** Storing prefix entries in the dictionary greatly simplifies
+** the process of matching and dispatching prefixes, avoids the
+** need to clean up a dynamically allocated prefix list when the system
+** goes away, but still allows prefixes to be allocated at runtime.
+*/
+
+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
+** code against the remainder of the word and returns true.
+**************************************************************************/
+int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si)
+{
+ int i;
+ FICL_HASH *pHash;
+ FICL_WORD *pFW = ficlLookup(pVM->pSys, 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;
+
+ pHash = (FICL_HASH *)(pFW->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++)
+ {
+ pFW = pHash->table[i];
+ while (pFW != NULL)
+ {
+ int n;
+ n = pFW->nName;
+ /*
+ ** 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))
+ {
+ /* (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);
+
+ return (int)FICL_TRUE;
+ }
+ pFW = pFW->link;
+ }
+ }
+
+ return FICL_FALSE;
+}
+
+
+static void tempBase(FICL_VM *pVM, int base)
+{
+ int oldbase = pVM->base;
+ STRINGINFO si = vmGetWord0(pVM);
+
+ pVM->base = base;
+ if (!ficlParseNumber(pVM, si))
+ {
+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not recognized", i, SI_PTR(si));
+ }
+
+ pVM->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);
+}
+
+
+/**************************************************************************
+ f i c l C o m p i l e P r e f i x
+** Build prefix support into the dictionary and the parser
+** Note: since prefixes always execute, they are effectively IMMEDIATE.
+** If they need to generate code in compile state you must add
+** this code explicitly.
+**************************************************************************/
+void ficlCompilePrefix(FICL_SYSTEM *pSys)
+{
+ FICL_DICT *dp = pSys->dp;
+ FICL_HASH *pHash;
+ FICL_HASH *pPrevCompile = dp->pCompile;
+#if (FICL_EXTENDED_PREFIX)
+ FICL_WORD *pFW;
+#endif
+
+ /*
+ ** 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));
+
+ /*
+ ** Put __tempbase in the forth-wordlist
+ */
+ dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT);
+
+ /*
+ ** Temporarily make the prefix list the compile wordlist so that
+ ** we can create some precompiled prefixes.
+ */
+ 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/stand/ficl/riscv/sysdep.c b/stand/ficl/riscv/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/riscv/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/riscv/sysdep.h b/stand/ficl/riscv/sysdep.h
new file mode 100644
index 0000000..3726b9e
--- /dev/null
+++ b/stand/ficl/riscv/sysdep.h
@@ -0,0 +1,411 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+** $FreeBSD$
+*/
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#if !defined IGNORE /* Macro to silence unused param warnings */
+#define IGNORE(x) (void)(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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 long
+#endif
+
+#if !defined FICL_UNS
+#define FICL_UNS unsigned long
+#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 64
+#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_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
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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 3
+#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);
+
+#endif /*__SYSDEP_H__*/
diff --git a/stand/ficl/search.c b/stand/ficl/search.c
new file mode 100644
index 0000000..d445cb3
--- /dev/null
+++ b/stand/ficl/search.c
@@ -0,0 +1,393 @@
+/*******************************************************************
+** s e a r c h . c
+** Forth Inspired Command Language
+** 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.9 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#include <string.h>
+#include "ficl.h"
+#include "math64.h"
+
+/**************************************************************************
+ d e f i n i t i o n s
+** SEARCH ( -- )
+** Make the compilation word list the same as the first word list in the
+** search order. Specifies that the names of subsequent definitions will
+** 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)
+{
+ FICL_DICT *pDict = vmGetDict(pVM);
+
+ assert(pDict);
+ if (pDict->nLists < 1)
+ {
+ vmThrowErr(pVM, "DEFINITIONS error - empty search order");
+ }
+
+ pDict->pCompile = pDict->pSearch[pDict->nLists-1];
+ return;
+}
+
+
+/**************************************************************************
+ f o r t h - w o r d l i s t
+** SEARCH ( -- wid )
+** Return wid, the identifier of the word list that includes all standard
+** 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)
+{
+ FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
+ stackPushPtr(pVM->pStack, pHash);
+ return;
+}
+
+
+/**************************************************************************
+ g e t - c u r r e n t
+** SEARCH ( -- wid )
+** Return wid, the identifier of the compilation word list.
+**************************************************************************/
+static void getCurrent(FICL_VM *pVM)
+{
+ ficlLockDictionary(TRUE);
+ stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ g e t - o r d e r
+** SEARCH ( -- widn ... wid1 n )
+** Returns the number of word lists n in the search order and the word list
+** identifiers widn ... wid1 identifying these word lists. wid1 identifies
+** 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)
+{
+ FICL_DICT *pDict = vmGetDict(pVM);
+ int nLists = pDict->nLists;
+ int i;
+
+ ficlLockDictionary(TRUE);
+ for (i = 0; i < nLists; i++)
+ {
+ stackPushPtr(pVM->pStack, pDict->pSearch[i]);
+ }
+
+ stackPushUNS(pVM->pStack, nLists);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ s e a r c h - w o r d l i s t
+** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
+** Find the definition identified by the string c-addr u in the word list
+** identified by wid. If the definition is not found, return zero. If the
+** 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)
+{
+ STRINGINFO si;
+ UNS16 hashCode;
+ FICL_WORD *pFW;
+ FICL_HASH *pHash = stackPopPtr(pVM->pStack);
+
+ si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
+ si.cp = stackPopPtr(pVM->pStack);
+ hashCode = hashHashCode(si);
+
+ ficlLockDictionary(TRUE);
+ pFW = hashLookup(pHash, si, hashCode);
+ ficlLockDictionary(FALSE);
+
+ if (pFW)
+ {
+ stackPushPtr(pVM->pStack, pFW);
+ stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
+ }
+ else
+ {
+ stackPushUNS(pVM->pStack, 0);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ s e t - c u r r e n t
+** SEARCH ( wid -- )
+** Set the compilation word list to the word list identified by wid.
+**************************************************************************/
+static void setCurrent(FICL_VM *pVM)
+{
+ FICL_HASH *pHash = stackPopPtr(pVM->pStack);
+ FICL_DICT *pDict = vmGetDict(pVM);
+ ficlLockDictionary(TRUE);
+ pDict->pCompile = pHash;
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ s e t - o r d e r
+** SEARCH ( widn ... wid1 n -- )
+** Set the search order to the word lists identified by widn ... wid1.
+** Subsequently, word list wid1 will be searched first, and word list
+** widn searched last. If n is zero, empty the search order. If n is minus
+** one, set the search order to the implementation-defined minimum
+** search order. The minimum search order shall include the words
+** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
+** be at least eight.
+**************************************************************************/
+static void setOrder(FICL_VM *pVM)
+{
+ int i;
+ int nLists = stackPopINT(pVM->pStack);
+ FICL_DICT *dp = vmGetDict(pVM);
+
+ if (nLists > FICL_DEFAULT_VOCS)
+ {
+ vmThrowErr(pVM, "set-order error: list would be too large");
+ }
+
+ ficlLockDictionary(TRUE);
+
+ if (nLists >= 0)
+ {
+ dp->nLists = nLists;
+ for (i = nLists-1; i >= 0; --i)
+ {
+ dp->pSearch[i] = stackPopPtr(pVM->pStack);
+ }
+ }
+ else
+ {
+ dictResetSearchOrder(dp);
+ }
+
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ f i c l - w o r d l i s t
+** SEARCH ( -- wid )
+** Create a new empty word list, returning its word list identifier wid.
+** The new word list may be returned from a pool of preallocated word
+** lists or may be dynamically allocated in data space. A system shall
+** 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
+** 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)
+{
+ FICL_DICT *dp = vmGetDict(pVM);
+ FICL_HASH *pHash;
+ FICL_UNS nBuckets;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+ nBuckets = stackPopUNS(pVM->pStack);
+ pHash = dictCreateWordlist(dp, nBuckets);
+ stackPushPtr(pVM->pStack, pHash);
+ return;
+}
+
+
+/**************************************************************************
+ S E A R C H >
+** ficl ( -- wid )
+** Pop wid off the search order. Error if the search order is empty
+**************************************************************************/
+static void searchPop(FICL_VM *pVM)
+{
+ FICL_DICT *dp = vmGetDict(pVM);
+ int nLists;
+
+ ficlLockDictionary(TRUE);
+ nLists = dp->nLists;
+ if (nLists == 0)
+ {
+ vmThrowErr(pVM, "search> error: empty search order");
+ }
+ stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ > S E A R C H
+** ficl ( wid -- )
+** Push wid onto the search order. Error if the search order is full.
+**************************************************************************/
+static void searchPush(FICL_VM *pVM)
+{
+ FICL_DICT *dp = vmGetDict(pVM);
+
+ ficlLockDictionary(TRUE);
+ if (dp->nLists > FICL_DEFAULT_VOCS)
+ {
+ vmThrowErr(pVM, ">search error: search order overflow");
+ }
+ dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
+ ficlLockDictionary(FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ W I D - G E T - N A M E
+** ficl ( wid -- c-addr u )
+** Get wid's (optional) name and push onto stack as a counted string
+**************************************************************************/
+static void widGetName(FICL_VM *pVM)
+{
+ FICL_HASH *pHash = vmPop(pVM).p;
+ char *cp = pHash->name;
+ FICL_INT len = 0;
+
+ if (cp)
+ len = strlen(cp);
+
+ vmPush(pVM, LVALUEtoCELL(cp));
+ vmPush(pVM, LVALUEtoCELL(len));
+ return;
+}
+
+/**************************************************************************
+ W I D - S E T - N A M E
+** ficl ( wid c-addr -- )
+** Set wid's name pointer to the \0 terminated string address supplied
+**************************************************************************/
+static void widSetName(FICL_VM *pVM)
+{
+ char *cp = (char *)vmPop(pVM).p;
+ FICL_HASH *pHash = vmPop(pVM).p;
+ pHash->name = cp;
+ return;
+}
+
+
+/**************************************************************************
+ setParentWid
+** 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)
+{
+ 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);
+
+ child->link = parent;
+ return;
+}
+
+
+/**************************************************************************
+ f i c l C o m p i l e S e a r c h
+** Builds the primitive wordset and the environment-query namespace.
+**************************************************************************/
+
+void ficlCompileSearch(FICL_SYSTEM *pSys)
+{
+ FICL_DICT *dp = pSys->dp;
+ assert (dp);
+
+ /*
+ ** 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);
+
+ /*
+ ** 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);
+ return;
+}
+
diff --git a/stand/ficl/softwords/classes.fr b/stand/ficl/softwords/classes.fr
new file mode 100644
index 0000000..b56da37
--- /dev/null
+++ b/stand/ficl/softwords/classes.fr
@@ -0,0 +1,173 @@
+\ #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
+\
+\ $FreeBSD$
+
+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/stand/ficl/softwords/ficlclass.fr b/stand/ficl/softwords/ficlclass.fr
new file mode 100644
index 0000000..6d75efb
--- /dev/null
+++ b/stand/ficl/softwords/ficlclass.fr
@@ -0,0 +1,86 @@
+\ #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
+\
+\ $FreeBSD$
+
+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/stand/ficl/softwords/ficllocal.fr b/stand/ficl/softwords/ficllocal.fr
new file mode 100644
index 0000000..c916089
--- /dev/null
+++ b/stand/ficl/softwords/ficllocal.fr
@@ -0,0 +1,49 @@
+\ ** 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 --
+\
+\ $FreeBSD$
+
+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/stand/ficl/softwords/fileaccess.fr b/stand/ficl/softwords/fileaccess.fr
new file mode 100644
index 0000000..7297df6
--- /dev/null
+++ b/stand/ficl/softwords/fileaccess.fr
@@ -0,0 +1,25 @@
+\ #if FICL_WANT_FILE
+\ **
+\ ** File Access words for ficl
+\ ** submitted by Larry Hastings, larry@hastings.org
+\ **
+\
+\ $FreeBSD$
+
+: 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
diff --git a/stand/ficl/softwords/forml.fr b/stand/ficl/softwords/forml.fr
new file mode 100644
index 0000000..1144ef5
--- /dev/null
+++ b/stand/ficl/softwords/forml.fr
@@ -0,0 +1,75 @@
+\ examples from FORML conference paper Nov 98
+\ sadler
+\
+\ $FreeBSD$
+
+.( 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/stand/ficl/softwords/freebsd.fr b/stand/ficl/softwords/freebsd.fr
new file mode 100644
index 0000000..96205c0
--- /dev/null
+++ b/stand/ficl/softwords/freebsd.fr
@@ -0,0 +1,36 @@
+\ ** Copyright (c) 1998 Daniel C. Sobral <dcs@freebsd.org>
+\ ** All rights reserved.
+\ **
+\ ** 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.
+\ **
+\ ** $FreeBSD$
+
+\ Words for use in scripts:
+\ % ignore errors here
+\ $ echo this line
+
+: tib> source >in @ tuck over >in ! - >r + r> ;
+: % tib> ['] evaluate catch drop ;
+: $ tib> 2dup type cr evaluate ;
+
+\ ** E N D F R E E B S D . F R
+
diff --git a/stand/ficl/softwords/ifbrack.fr b/stand/ficl/softwords/ifbrack.fr
new file mode 100644
index 0000000..a8c6062
--- /dev/null
+++ b/stand/ficl/softwords/ifbrack.fr
@@ -0,0 +1,50 @@
+\ ** ficl/softwords/ifbrack.fr
+\ ** ANS conditional compile directives [if] [else] [then]
+\ ** Requires ficl 2.0 or greater...
+\
+\ $FreeBSD$
+
+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/stand/ficl/softwords/jhlocal.fr b/stand/ficl/softwords/jhlocal.fr
new file mode 100644
index 0000000..12ccb9f
--- /dev/null
+++ b/stand/ficl/softwords/jhlocal.fr
@@ -0,0 +1,105 @@
+\ #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
+\
+\ $FreeBSD$
+
+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/stand/ficl/softwords/marker.fr b/stand/ficl/softwords/marker.fr
new file mode 100644
index 0000000..ee3c9bd
--- /dev/null
+++ b/stand/ficl/softwords/marker.fr
@@ -0,0 +1,27 @@
+\ ** ficl/softwords/marker.fr
+\ ** Ficl implementation of CORE EXT MARKER
+\ John Sadler, 4 Oct 98
+\ Requires ficl 2.02 FORGET-WID !!
+\
+\ $FreeBSD$
+
+: 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/stand/ficl/softwords/oo.fr b/stand/ficl/softwords/oo.fr
new file mode 100644
index 0000000..b1c8e21
--- /dev/null
+++ b/stand/ficl/softwords/oo.fr
@@ -0,0 +1,694 @@
+\ #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
+\
+\ $FreeBSD$
+
+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
diff --git a/stand/ficl/softwords/prefix.fr b/stand/ficl/softwords/prefix.fr
new file mode 100644
index 0000000..ae1727f
--- /dev/null
+++ b/stand/ficl/softwords/prefix.fr
@@ -0,0 +1,59 @@
+\ **
+\ ** 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
+\
+\ $FreeBSD$
+
+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
diff --git a/stand/ficl/softwords/softcore.awk b/stand/ficl/softwords/softcore.awk
new file mode 100644
index 0000000..5a97999
--- /dev/null
+++ b/stand/ficl/softwords/softcore.awk
@@ -0,0 +1,183 @@
+#!/usr/bin/awk -f
+#
+# Convert forth source files to a giant C string
+#
+# Joe Abley <jabley@patho.gen.nz>, 12 January 1999
+#
+# 02-oct-1999: Cleaned up awk slightly; added some additional logic
+# suggested by dcs to compress the stored forth program.
+#
+# Note! This script uses strftime() which is a gawk-ism, and the
+# POSIX [[:space:]] character class.
+#
+# $FreeBSD$
+
+BEGIN \
+{
+ printf "/*******************************************************************\n";
+ printf "** s o f t c o r e . c\n";
+ printf "** Forth Inspired Command Language -\n";
+ printf "** Words from CORE set written in FICL\n";
+ printf "** Author: John Sadler (john_sadler@alum.mit.edu)\n";
+ printf "** Created: 27 December 1997\n";
+ printf "** Last update: %s\n", datestamp;
+ printf "*******************************************************************/\n";
+ printf "/*\n";
+ printf "** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.awk\n";
+ printf "** Make changes to the .fr files in ficl/softwords instead.\n";
+ printf "** This file contains definitions that are compiled into the\n";
+ printf "** system dictionary by the first virtual machine to be created.\n";
+ printf "** Created automagically by ficl/softwords/softcore.awk\n";
+ printf "*/\n";
+ printf "/*\n";
+ printf "** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)\n";
+ printf "** All rights reserved.\n";
+ printf "**\n";
+ printf "** Get the latest Ficl release at http://ficl.sourceforge.net\n";
+ printf "**\n";
+ printf "** I am interested in hearing from anyone who uses ficl. If you have\n";
+ printf "** a problem, a success story, a defect, an enhancement request, or\n";
+ printf "** if you would like to contribute to the ficl release, please send\n";
+ printf "** contact me by email at the address above.\n";
+ printf "**\n";
+ printf "** L I C E N S E and D I S C L A I M E R\n";
+ printf "** \n";
+ printf "** Redistribution and use in source and binary forms, with or without\n";
+ printf "** modification, are permitted provided that the following conditions\n";
+ printf "** are met:\n";
+ printf "** 1. Redistributions of source code must retain the above copyright\n";
+ printf "** notice, this list of conditions and the following disclaimer.\n";
+ printf "** 2. Redistributions in binary form must reproduce the above copyright\n";
+ printf "** notice, this list of conditions and the following disclaimer in the\n";
+ printf "** documentation and/or other materials provided with the distribution.\n";
+ printf "**\n";
+ printf "** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND\n";
+ printf "** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n";
+ printf "** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n";
+ printf "** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE\n";
+ printf "** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n";
+ printf "** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n";
+ printf "** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n";
+ printf "** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n";
+ printf "** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n";
+ printf "** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n";
+ printf "** SUCH DAMAGE.\n";
+ printf "*/\n";
+ printf "\n";
+ printf "\n#include \"ficl.h\"\n";
+ printf "\nstatic char softWords[] =\n";
+ printf "#if FICL_WANT_SOFTWORDS\n";
+
+ commenting = 0;
+}
+
+# some general early substitutions
+{
+ gsub(/\t/, " "); # replace each tab with 4 spaces
+ gsub(/\"/, "\\\""); # escape quotes
+ gsub(/\\[[:space:]]+$/, ""); # toss empty comments
+}
+
+# strip out empty lines
+/^ *$/ \
+{
+ next;
+}
+
+# emit / ** lines as multi-line C comments
+/^\\[[:space:]]\*\*/ \
+{
+ sub(/^\\[[:space:]]/, "");
+ if (commenting == 0) printf "/*\n";
+ printf "%s\n", $0;
+ commenting = 1;
+ next;
+}
+
+# strip blank lines
+/^[[:space:]]*$/ \
+{
+ next;
+}
+
+# function to close a comment, used later
+function end_comments()
+{
+ commenting = 0;
+ printf "*/\n";
+}
+
+# pass commented preprocessor directives
+/^\\[[:space:]]#/ \
+{
+ if (commenting) end_comments();
+ sub(/^\\[[:space:]]/, "");
+ printf "%s\n", $0;
+ next;
+}
+
+# toss all other full-line \ comments
+/^\\/ \
+{
+ if (commenting) end_comments();
+ next;
+}
+
+# lop off trailing \ comments
+/\\[[:space:]]+/ \
+{
+ sub(/\\[[:space:]]+.*$/, "");
+}
+
+# expunge ( ) comments
+/[[:space:]]+\([[:space:]][^)]*\)/ \
+{
+ sub(/[[:space:]]+\([[:space:]][^)]*\)/, "");
+}
+
+# remove leading spaces
+/^[[:space:]]+/ \
+{
+ sub(/^[[:space:]]+/, "");
+}
+
+# removing trailing spaces
+/[[:space:]]+$/ \
+{
+ sub(/[[:space:]]+$/, "");
+}
+
+# strip out empty lines again (preceding rules may have generated some)
+/^[[:space:]]*$/ \
+{
+ if (commenting) end_comments();
+ next;
+}
+
+# emit all other lines as quoted string fragments
+{
+ if (commenting) end_comments();
+
+ printf " \"%s \"\n", $0;
+ next;
+}
+
+END \
+{
+ if (commenting) end_comments();
+ printf "#endif /* WANT_SOFTWORDS */\n";
+ printf " \"quit \";\n";
+ printf "\n\nvoid ficlCompileSoftCore(FICL_SYSTEM *pSys)\n";
+ printf "{\n";
+ printf " FICL_VM *pVM = pSys->vmList;\n";
+ printf " CELL id = pVM->sourceID;\n";
+ printf " int ret = sizeof (softWords);\n";
+ printf " assert(pVM);\n";
+ printf " pVM->sourceID.i = -1;\n";
+ printf " ret = ficlExec(pVM, softWords);\n";
+ printf " pVM->sourceID = id;\n";
+ printf " if (ret == VM_ERREXIT)\n";
+ printf " assert(FALSE);\n";
+ printf " return;\n";
+ printf "}\n";
+}
diff --git a/stand/ficl/softwords/softcore.fr b/stand/ficl/softwords/softcore.fr
new file mode 100644
index 0000000..a70ebaa
--- /dev/null
+++ b/stand/ficl/softwords/softcore.fr
@@ -0,0 +1,206 @@
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+\
+\ $FreeBSD$
+
+\ ** Ficl USER variables
+\ ** See words.c for primitive def'n of USER
+\ #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
+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
+\ 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
+
diff --git a/stand/ficl/softwords/string.fr b/stand/ficl/softwords/string.fr
new file mode 100644
index 0000000..dabb390
--- /dev/null
+++ b/stand/ficl/softwords/string.fr
@@ -0,0 +1,148 @@
+\ #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
+\
+\ $FreeBSD$
+
+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/stand/ficl/sparc64/sysdep.c b/stand/ficl/sparc64/sysdep.c
new file mode 100644
index 0000000..ad38660
--- /dev/null
+++ b/stand/ficl/sparc64/sysdep.c
@@ -0,0 +1,99 @@
+/*******************************************************************
+** 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...
+**
+*******************************************************************/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdio.h>
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+/*
+******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
+*/
+
+#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 */
diff --git a/stand/ficl/sparc64/sysdep.h b/stand/ficl/sparc64/sysdep.h
new file mode 100644
index 0000000..0a6ca33
--- /dev/null
+++ b/stand/ficl/sparc64/sysdep.h
@@ -0,0 +1,412 @@
+/*******************************************************************
+ 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.6 2001-04-26 21:41:55-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
+**
+** 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.
+**
+** 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.
+**
+** $Id: sysdep.h,v 1.6 2001-04-26 21:41:55-07 jsadler Exp jsadler $
+*/
+
+/* $FreeBSD$ */
+
+#if !defined (__SYSDEP_H__)
+#define __SYSDEP_H__
+
+#include <sys/types.h>
+
+#include <stddef.h> /* size_t, NULL */
+#include <setjmp.h>
+#include <assert.h>
+
+#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
+
+
+/*
+** System dependent data type declarations...
+*/
+#if !defined INT32
+#define INT32 int
+#endif
+
+#if !defined UNS32
+#define UNS32 unsigned int
+#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 long
+#endif
+
+#if !defined FICL_UNS
+#define FICL_UNS unsigned long
+#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 64
+#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_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
+*/
+#if !defined (FICL_PLATFORM_EXTEND)
+#define FICL_PLATFORM_EXTEND 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 0
+#endif
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER 1
+#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 260
+#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_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
+** included as part of softcore.c)
+*/
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
+#endif
+
+/*
+** FICL_ALIGN is the power of two to which the dictionary
+** pointer address must be aligned. This value is usually
+** either 1 or 2, depending on the memory architecture
+** 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 3
+#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);
+
+#endif /*__SYSDEP_H__*/
diff --git a/stand/ficl/stack.c b/stand/ficl/stack.c
new file mode 100644
index 0000000..f98a3b6
--- /dev/null
+++ b/stand/ficl/stack.c
@@ -0,0 +1,372 @@
+/*******************************************************************
+** s t a c k . c
+** Forth Inspired Command Language
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 16 Oct 1997
+** $Id: stack.c,v 1.10 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdlib.h>
+#else
+#include <stand.h>
+#endif
+#include "ficl.h"
+
+#define STKDEPTH(s) ((s)->sp - (s)->base)
+
+/*
+** 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
+** 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,
+** the function checks the stack state for underflow and overflow.
+** If nCells > 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)
+{
+ FICL_STACK *pStack = pVM->pStack;
+ int nFree = pStack->base + pStack->nCells - pStack->sp;
+
+ if (popCells > STKDEPTH(pStack))
+ {
+ vmThrowErr(pVM, "Error: stack underflow");
+ }
+
+ if (nFree < pushCells - popCells)
+ {
+ vmThrowErr(pVM, "Error: stack overflow");
+ }
+
+ return;
+}
+
+#if FICL_WANT_FLOAT
+void vmCheckFStack(FICL_VM *pVM, int popCells, int pushCells)
+{
+ 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");
+ }
+}
+#endif
+
+/*******************************************************************
+ s t a c k C r e a t e
+**
+*******************************************************************/
+
+FICL_STACK *stackCreate(unsigned nCells)
+{
+ size_t size = sizeof (FICL_STACK) + nCells * sizeof (CELL);
+ FICL_STACK *pStack = ficlMalloc(size);
+
+#if FICL_ROBUST
+ assert (nCells != 0);
+ assert (pStack != NULL);
+#endif
+
+ pStack->nCells = nCells;
+ pStack->sp = pStack->base;
+ pStack->pFrame = NULL;
+ return pStack;
+}
+
+
+/*******************************************************************
+ s t a c k D e l e t e
+**
+*******************************************************************/
+
+void stackDelete(FICL_STACK *pStack)
+{
+ if (pStack)
+ ficlFree(pStack);
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k D e p t h
+**
+*******************************************************************/
+
+int stackDepth(FICL_STACK *pStack)
+{
+ return STKDEPTH(pStack);
+}
+
+/*******************************************************************
+ s t a c k D r o p
+**
+*******************************************************************/
+
+void stackDrop(FICL_STACK *pStack, int n)
+{
+#if FICL_ROBUST
+ assert(n > 0);
+#endif
+ pStack->sp -= n;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k F e t c h
+**
+*******************************************************************/
+
+CELL stackFetch(FICL_STACK *pStack, int n)
+{
+ return pStack->sp[-n-1];
+}
+
+void stackStore(FICL_STACK *pStack, int n, CELL c)
+{
+ pStack->sp[-n-1] = c;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k G e t T o p
+**
+*******************************************************************/
+
+CELL stackGetTop(FICL_STACK *pStack)
+{
+ return pStack->sp[-1];
+}
+
+
+/*******************************************************************
+ 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
+*******************************************************************/
+
+void stackLink(FICL_STACK *pStack, int nCells)
+{
+ stackPushPtr(pStack, pStack->pFrame);
+ pStack->pFrame = pStack->sp;
+ pStack->sp += nCells;
+ return;
+}
+
+
+/*******************************************************************
+ 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()
+*******************************************************************/
+
+void stackUnlink(FICL_STACK *pStack)
+{
+ pStack->sp = pStack->pFrame;
+ pStack->pFrame = stackPopPtr(pStack);
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k P i c k
+**
+*******************************************************************/
+
+void stackPick(FICL_STACK *pStack, int n)
+{
+ stackPush(pStack, stackFetch(pStack, n));
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k P o p
+**
+*******************************************************************/
+
+CELL stackPop(FICL_STACK *pStack)
+{
+ return *--pStack->sp;
+}
+
+void *stackPopPtr(FICL_STACK *pStack)
+{
+ return (*--pStack->sp).p;
+}
+
+FICL_UNS stackPopUNS(FICL_STACK *pStack)
+{
+ return (*--pStack->sp).u;
+}
+
+FICL_INT stackPopINT(FICL_STACK *pStack)
+{
+ return (*--pStack->sp).i;
+}
+
+#if (FICL_WANT_FLOAT)
+float stackPopFloat(FICL_STACK *pStack)
+{
+ return (*(--pStack->sp)).f;
+}
+#endif
+
+/*******************************************************************
+ s t a c k P u s h
+**
+*******************************************************************/
+
+void stackPush(FICL_STACK *pStack, CELL c)
+{
+ *pStack->sp++ = c;
+}
+
+void stackPushPtr(FICL_STACK *pStack, void *ptr)
+{
+ *pStack->sp++ = LVALUEtoCELL(ptr);
+}
+
+void stackPushUNS(FICL_STACK *pStack, FICL_UNS u)
+{
+ *pStack->sp++ = LVALUEtoCELL(u);
+}
+
+void stackPushINT(FICL_STACK *pStack, FICL_INT i)
+{
+ *pStack->sp++ = LVALUEtoCELL(i);
+}
+
+#if (FICL_WANT_FLOAT)
+void stackPushFloat(FICL_STACK *pStack, FICL_FLOAT f)
+{
+ *pStack->sp++ = LVALUEtoCELL(f);
+}
+#endif
+
+/*******************************************************************
+ s t a c k R e s e t
+**
+*******************************************************************/
+
+void stackReset(FICL_STACK *pStack)
+{
+ pStack->sp = pStack->base;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k R o l l
+** Roll nth stack entry to the top (counting from zero), if n is
+** >= 0. Drop other entries as needed to fill the hole.
+** If n < 0, roll top-of-stack to nth entry, pushing others
+** upward as needed to fill the hole.
+*******************************************************************/
+
+void stackRoll(FICL_STACK *pStack, int n)
+{
+ CELL c;
+ CELL *pCell;
+
+ if (n == 0)
+ return;
+ else if (n > 0)
+ {
+ pCell = pStack->sp - n - 1;
+ c = *pCell;
+
+ for (;n > 0; --n, pCell++)
+ {
+ *pCell = pCell[1];
+ }
+
+ *pCell = c;
+ }
+ else
+ {
+ pCell = pStack->sp - 1;
+ c = *pCell;
+
+ for (; n < 0; ++n, pCell--)
+ {
+ *pCell = pCell[-1];
+ }
+
+ *pCell = c;
+ }
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k S e t T o p
+**
+*******************************************************************/
+
+void stackSetTop(FICL_STACK *pStack, CELL c)
+{
+ pStack->sp[-1] = c;
+ return;
+}
+
+
diff --git a/stand/ficl/testmain.c b/stand/ficl/testmain.c
new file mode 100644
index 0000000..7167f30
--- /dev/null
+++ b/stand/ficl/testmain.c
@@ -0,0 +1,345 @@
+/*
+** stub main for testing FICL under userland
+** $Id: testmain.c,v 1.13 2001/12/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <time.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "ficl.h"
+
+/*
+** Ficl interface to getcwd
+** Prints the current working directory using the VM's
+** textOut method...
+*/
+static void ficlGetCWD(FICL_VM *pVM)
+{
+ char *cp;
+
+ cp = getcwd(NULL, 80);
+ vmTextOut(pVM, cp, 1);
+ free(cp);
+ return;
+}
+
+/*
+** Ficl interface to chdir
+** Gets a newline (or NULL) delimited string from the input
+** and feeds it to chdir()
+** 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 system()
+** Example:
+** system rm -rf /
+** \ 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;
+
+ result = ficlExecC(pVM, cp, len);
+ if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
+ {
+ 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;
+}
+
+
+static void execxt(FICL_VM *pVM)
+{
+ FICL_WORD *pFW;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ pFW = stackPopPtr(pVM->pStack);
+ ficlExecXT(pVM, pFW);
+
+ 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, "execxt", execxt, 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;
+}
+
+
+int main(int argc, char **argv)
+{
+ char in[256];
+ FICL_VM *pVM;
+ FICL_SYSTEM *pSys;
+
+ pSys = ficlInitSystem(10000);
+ buildTestInterface(pSys);
+ pVM = ficlNewVM(pSys);
+
+ 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]);
+ ficlEvaluate(pVM, in);
+ }
+
+ for (;;)
+ {
+ int ret;
+ if (fgets(in, sizeof(in) - 1, stdin) == NULL)
+ break;
+ ret = ficlExec(pVM, in);
+ if (ret == VM_USEREXIT)
+ {
+ ficlTermSystem(pSys);
+ break;
+ }
+ }
+
+ return 0;
+}
+
diff --git a/stand/ficl/tools.c b/stand/ficl/tools.c
new file mode 100644
index 0000000..db1e948
--- /dev/null
+++ b/stand/ficl/tools.c
@@ -0,0 +1,918 @@
+/*******************************************************************
+** t o o l s . c
+** 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/05 07:21:34 jsadler 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.
+*/
+
+/*
+** NOTES:
+** SEE needs information about the addresses of functions that
+** 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
+**
+** Step and break debugger for Ficl
+** debug ( xt -- ) Start debugging an xt
+** Set a breakpoint
+** Specify breakpoint default action
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdlib.h>
+#include <stdio.h> /* sprintf */
+#include <ctype.h>
+#else
+#include <stand.h>
+#endif
+#include <string.h>
+#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
+
+#endif
+
+
+/**************************************************************************
+ v m S e t B r e a k
+** Set a breakpoint at the current value of IP by
+** storing that address in a BREAKPOINT record
+**************************************************************************/
+static void vmSetBreak(FICL_VM *pVM, FICL_BREAKPOINT *pBP)
+{
+ FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
+ assert(pStep);
+
+ pBP->address = pVM->ip;
+ pBP->origXT = *pVM->ip;
+ *pVM->ip = pStep;
+}
+
+
+/**************************************************************************
+** d e b u g P r o m p t
+**************************************************************************/
+static void debugPrompt(FICL_VM *pVM)
+{
+ 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;
+}
+
+
+#if 0
+static int isPrimitive(FICL_WORD *pFW)
+{
+ WORDKIND wk = ficlWordClassify(pFW);
+ 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
+**************************************************************************/
+#define nSEARCH_CELLS 100
+
+static FICL_WORD *findEnclosingWord(FICL_VM *pVM, CELL *cp)
+{
+ 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;
+}
+
+
+/**************************************************************************
+ 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);
+
+ for (; pc->p != pSemiParen; pc++)
+ {
+ FICL_WORD *pFW = (FICL_WORD *)(pc->p);
+
+ cp = pVM->pad;
+ if ((void *)pc == (void *)pVM->ip)
+ *cp++ = '>';
+ else
+ *cp++ = ' ';
+ cp += sprintf(cp, "%3d ", (int)(pc-param0));
+
+ if (isAFiclWord(pd, pFW))
+ {
+ WORDKIND kind = ficlWordClassify(pFW);
+ CELL c;
+
+ 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, (unsigned long)c.u);
+ }
+ else
+ sprintf(cp, "literal %ld (%#lx)",
+ (long)c.i, (unsigned long)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)", (int)(pc+c.i-param0));
+ else
+ sprintf(cp, "until (branch %d)", (int)(pc+c.i-param0));
+ break;
+ case BRANCH:
+ c = *++pc;
+ if (c.i == 0)
+ sprintf(cp, "repeat (branch %d)", (int)(pc+c.i-param0));
+ else if (c.i == 1)
+ sprintf(cp, "else (branch %d)", (int)(pc+c.i-param0));
+ else
+ sprintf(cp, "endof (branch %d)", (int)(pc+c.i-param0));
+ break;
+
+ case OF:
+ c = *++pc;
+ sprintf(cp, "of (branch %d)", (int)(pc+c.i-param0));
+ break;
+
+ case QDO:
+ c = *++pc;
+ sprintf(cp, "?do (leave %d)", (int)((CELL *)c.p-param0));
+ break;
+ case DO:
+ c = *++pc;
+ sprintf(cp, "do (leave %d)", (int)((CELL *)c.p-param0));
+ break;
+ case LOOP:
+ c = *++pc;
+ sprintf(cp, "loop (branch %d)", (int)(pc+c.i-param0));
+ break;
+ case PLOOP:
+ c = *++pc;
+ sprintf(cp, "+loop (branch %d)", (int)(pc+c.i-param0));
+ break;
+ default:
+ sprintf(cp, "%.*s", pFW->nName, pFW->name);
+ break;
+ }
+
+ }
+ else /* probably not a word - punt and print value */
+ {
+ sprintf(cp, "%ld ( %#lx )", (long)pc->i, (unsigned long)pc->u);
+ }
+
+ vmTextOut(pVM, pVM->pad, 1);
+ }
+
+ vmTextOut(pVM, ";", 1);
+}
+
+/*
+** Here's the outer part of the decompiler. It's
+** just a big nested conditional that checks the
+** CFA of the word to decompile for each kind of
+** known word-builder code, and tries to do
+** something appropriate. If the CFA is not recognized,
+** just indicate that it is a primitive.
+*/
+static void seeXT(FICL_VM *pVM)
+{
+ FICL_WORD *pFW;
+ WORDKIND kind;
+
+ pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
+ kind = ficlWordClassify(pFW);
+
+ switch (kind)
+ {
+ case COLON:
+ sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
+ vmTextOut(pVM, pVM->pad, 1);
+ seeColon(pVM, pFW->param);
+ break;
+
+ case DOES:
+ vmTextOut(pVM, "does>", 1);
+ seeColon(pVM, (CELL *)pFW->param->p);
+ break;
+
+ case CREATE:
+ vmTextOut(pVM, "create", 1);
+ break;
+
+ case VARIABLE:
+ sprintf(pVM->pad, "variable = %ld (%#lx)",
+ (long)pFW->param->i, (unsigned long)pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ break;
+
+#if FICL_WANT_USER
+ case USER:
+ sprintf(pVM->pad, "user variable %ld (%#lx)",
+ (long)pFW->param->i, (unsigned long)pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+ break;
+#endif
+
+ case CONSTANT:
+ sprintf(pVM->pad, "constant = %ld (%#lx)",
+ (long)pFW->param->i, (unsigned long)pFW->param->u);
+ vmTextOut(pVM, pVM->pad, 1);
+
+ default:
+ sprintf(pVM->pad, "%.*s is a primitive", pFW->nName, pFW->name);
+ vmTextOut(pVM, pVM->pad, 1);
+ break;
+ }
+
+ if (pFW->flags & FW_IMMEDIATE)
+ {
+ vmTextOut(pVM, "immediate", 1);
+ }
+
+ if (pFW->flags & FW_COMPILE)
+ {
+ vmTextOut(pVM, "compile-only", 1);
+ }
+
+ return;
+}
+
+
+static void see(FICL_VM *pVM)
+{
+ ficlTick(pVM);
+ seeXT(pVM);
+ return;
+}
+
+
+/**************************************************************************
+ f i c l D e b u g X T
+** debug ( xt -- )
+** Given an xt of a colon definition or a word defined by DOES>, set the
+** VM up to debug the word: push IP, set the xt as the next thing to execute,
+** 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)
+{
+ FICL_WORD *xt = stackPopPtr(pVM->pStack);
+ WORDKIND wk = ficlWordClassify(xt);
+
+ stackPushPtr(pVM->pStack, xt);
+ seeXT(pVM);
+
+ switch (wk)
+ {
+ case COLON:
+ case DOES:
+ /*
+ ** Run the colon code and set a breakpoint at the next instruction
+ */
+ vmExecute(pVM, xt);
+ vmSetBreak(pVM, &(pVM->pSys->bpStep));
+ break;
+
+ default:
+ vmExecute(pVM, xt);
+ break;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ s t e p I n
+** 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)
+{
+ /*
+ ** Do one step of the inner loop
+ */
+ {
+ M_VM_STEP(pVM)
+ }
+
+ /*
+ ** Now set a breakpoint at the next instruction
+ */
+ vmSetBreak(pVM, &(pVM->pSys->bpStep));
+
+ return;
+}
+
+
+/**************************************************************************
+ s t e p O v e r
+** 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)
+{
+ FICL_WORD *pFW;
+ WORDKIND kind;
+ FICL_WORD *pStep = ficlLookup(pVM->pSys, "step-break");
+ assert(pStep);
+
+ pFW = *pVM->ip;
+ kind = ficlWordClassify(pFW);
+
+ switch (kind)
+ {
+ case COLON:
+ case DOES:
+ /*
+ ** assume that the next cell holds an instruction
+ ** set a breakpoint there and return to the inner interp
+ */
+ pVM->pSys->bpStep.address = pVM->ip + 1;
+ pVM->pSys->bpStep.origXT = pVM->ip[1];
+ pVM->ip[1] = pStep;
+ break;
+
+ default:
+ stepIn(pVM);
+ break;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ s t e p - b r e a k
+** FICL
+** Handles breakpoints for stepped execution.
+** Upon entry, bpStep contains the address and replaced instruction
+** of the current breakpoint.
+** Clear the breakpoint
+** Get a command from the console.
+** i (step in) - execute the current instruction and set a new breakpoint
+** at the IP
+** o (step over) - execute the current instruction to completion and set
+** a new breakpoint at the IP
+** g (go) - execute the current instruction and exit
+** q (quit) - abort current word
+** b (toggle breakpoint)
+**************************************************************************/
+void stepBreak(FICL_VM *pVM)
+{
+ STRINGINFO si;
+ FICL_WORD *pFW;
+ FICL_WORD *pOnStep;
+
+ if (!pVM->fRestart)
+ {
+ assert(pVM->pSys->bpStep.address);
+ assert(pVM->pSys->bpStep.origXT);
+ /*
+ ** Clear the breakpoint that caused me to run
+ ** Restore the original instruction at the breakpoint,
+ ** and restore the IP
+ */
+ pVM->ip = (IPTYPE)(pVM->pSys->bpStep.address);
+ *pVM->ip = pVM->pSys->bpStep.origXT;
+
+ /*
+ ** If there's an onStep, do it
+ */
+ pOnStep = ficlLookup(pVM->pSys, "on-step");
+ if (pOnStep)
+ ficlExecXT(pVM, 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
+
+ vmTextOut(pVM, pVM->pad, 1);
+ debugPrompt(pVM);
+ }
+ else
+ {
+ pVM->fRestart = 0;
+ }
+
+ si = vmGetWord(pVM);
+
+ 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)
+ {
+ 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);
+ }
+ 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);
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ b y e
+** TOOLS
+** 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)
+{
+ vmThrow(pVM, VM_USEREXIT);
+ return;
+}
+
+
+/**************************************************************************
+ d i s p l a y S t a c k
+** TOOLS
+** Display the parameter stack (code for ".s")
+**************************************************************************/
+static void displayPStack(FICL_VM *pVM)
+{
+ FICL_STACK *pStk = pVM->pStack;
+ int d = stackDepth(pStk);
+ int i;
+ CELL *pCell;
+
+ vmCheckStack(pVM, 0, 0);
+
+ if (d == 0)
+ vmTextOut(pVM, "(Stack Empty) ", 0);
+ else
+ {
+ pCell = pStk->base;
+ for (i = 0; i < d; i++)
+ {
+ vmTextOut(pVM, ltoa((*pCell++).i, pVM->pad, pVM->base), 0);
+ vmTextOut(pVM, " ", 0);
+ }
+ }
+ return;
+}
+
+
+static void displayRStack(FICL_VM *pVM)
+{
+ FICL_STACK *pStk = pVM->rStack;
+ int d = stackDepth(pStk);
+ int i;
+ CELL *pCell;
+ FICL_DICT *dp = vmGetDict(pVM);
+
+ vmCheckStack(pVM, 0, 0);
+
+ if (d == 0)
+ vmTextOut(pVM, "(Stack Empty) ", 0);
+ else
+ {
+ pCell = pStk->base;
+ for (i = 0; i < d; i++)
+ {
+ 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);
+ }
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ f o r g e t - w i d
+**
+**************************************************************************/
+static void forgetWid(FICL_VM *pVM)
+{
+ FICL_DICT *pDict = vmGetDict(pVM);
+ FICL_HASH *pHash;
+
+ pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
+ hashForget(pHash, pDict->here);
+
+ return;
+}
+
+
+/**************************************************************************
+ f o r g e t
+** TOOLS EXT ( "<spaces>name" -- )
+** Skip leading space delimiters. Parse name delimited by a space.
+** Find name, then delete name from the dictionary along with all
+** words added to the dictionary after name. An ambiguous
+** condition exists if name cannot be found.
+**
+** If the Search-Order word set is present, FORGET searches the
+** compilation word list. An ambiguous condition exists if the
+** compilation word list is deleted.
+**************************************************************************/
+static void forget(FICL_VM *pVM)
+{
+ void *where;
+ FICL_DICT *pDict = vmGetDict(pVM);
+ FICL_HASH *pHash = pDict->pCompile;
+
+ ficlTick(pVM);
+ where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
+ hashForget(pHash, where);
+ pDict->here = PTRtoCELL where;
+
+ return;
+}
+
+
+/**************************************************************************
+ l i s t W o r d s
+**
+**************************************************************************/
+#define nCOLWIDTH 8
+static void listWords(FICL_VM *pVM)
+{
+ FICL_DICT *dp = vmGetDict(pVM);
+ FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
+ FICL_WORD *wp;
+ int nChars = 0;
+ int len;
+ int y = 0;
+ unsigned i;
+ int nWords = 0;
+ char *cp;
+ char *pPad = pVM->pad;
+
+ for (i = 0; i < pHash->size; i++)
+ {
+ for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ {
+ if (wp->nName == 0) /* ignore :noname defs */
+ continue;
+
+ cp = wp->name;
+ nChars += sprintf(pPad + nChars, "%s", cp);
+
+ if (nChars > 70)
+ {
+ pPad[nChars] = '\0';
+ nChars = 0;
+ y++;
+ if(y>23) {
+ y=0;
+ vmTextOut(pVM, "--- Press Enter to continue ---",0);
+ getchar();
+ vmTextOut(pVM,"\r",0);
+ }
+ vmTextOut(pVM, pPad, 1);
+ }
+ else
+ {
+ len = nCOLWIDTH - nChars % nCOLWIDTH;
+ while (len-- > 0)
+ pPad[nChars++] = ' ';
+ }
+
+ if (nChars > 70)
+ {
+ pPad[nChars] = '\0';
+ nChars = 0;
+ y++;
+ if(y>23) {
+ y=0;
+ vmTextOut(pVM, "--- Press Enter to continue ---",0);
+ getchar();
+ vmTextOut(pVM,"\r",0);
+ }
+ vmTextOut(pVM, pPad, 1);
+ }
+ }
+ }
+
+ if (nChars > 0)
+ {
+ pPad[nChars] = '\0';
+ nChars = 0;
+ vmTextOut(pVM, pPad, 1);
+ }
+
+ 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);
+ return;
+}
+
+
+/**************************************************************************
+ l i s t E n v
+** Print symbols defined in the environment
+**************************************************************************/
+static void listEnv(FICL_VM *pVM)
+{
+ FICL_DICT *dp = pVM->pSys->envp;
+ FICL_HASH *pHash = dp->pForthWords;
+ FICL_WORD *wp;
+ unsigned i;
+ int nWords = 0;
+
+ for (i = 0; i < pHash->size; i++)
+ {
+ for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ {
+ vmTextOut(pVM, wp->name, 1);
+ }
+ }
+
+ 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);
+ return;
+}
+
+
+/**************************************************************************
+ e n v C o n s t a n t
+** Ficl interface to ficlSetEnv and ficlSetEnvD - allow ficl code to set
+** environment constants...
+**************************************************************************/
+static void envConstant(FICL_VM *pVM)
+{
+ unsigned value;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ vmGetWordToPad(pVM);
+ value = POPUNS();
+ ficlSetEnv(pVM->pSys, pVM->pad, (FICL_UNS)value);
+ return;
+}
+
+static void env2Constant(FICL_VM *pVM)
+{
+ unsigned v1, v2;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+
+ vmGetWordToPad(pVM);
+ v2 = POPUNS();
+ v1 = POPUNS();
+ ficlSetEnvD(pVM->pSys, pVM->pad, v1, v2);
+ return;
+}
+
+
+/**************************************************************************
+ f i c l C o m p i l e T o o l s
+** Builds wordset for debugger and TOOLS optional word set
+**************************************************************************/
+
+void ficlCompileTools(FICL_SYSTEM *pSys)
+{
+ FICL_DICT *dp = pSys->dp;
+ assert (dp);
+
+ /*
+ ** 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);
+
+ /*
+ ** Set TOOLS environment query values
+ */
+ ficlSetEnv(pSys, "tools", FICL_TRUE);
+ ficlSetEnv(pSys, "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);
+
+ return;
+}
+
diff --git a/stand/ficl/unix.c b/stand/ficl/unix.c
new file mode 100644
index 0000000..5b56440
--- /dev/null
+++ b/stand/ficl/unix.c
@@ -0,0 +1,23 @@
+/* $FreeBSD$ */
+
+#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/stand/ficl/vm.c b/stand/ficl/vm.c
new file mode 100644
index 0000000..97a4f04
--- /dev/null
+++ b/stand/ficl/vm.c
@@ -0,0 +1,805 @@
+/*******************************************************************
+** v m . c
+** Forth Inspired Command Language - virtual machine methods
+** Author: John Sadler (john_sadler@alum.mit.edu)
+** Created: 19 July 1997
+** $Id: vm.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
+*******************************************************************/
+/*
+** 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.
+*/
+/*
+** 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.
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdlib.h>
+#include <stdio.h>
+#include <ctype.h>
+#else
+#include <stand.h>
+#endif
+#include <stdarg.h>
+#include <string.h>
+#include "ficl.h"
+
+static char digits[] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+
+/**************************************************************************
+ v m B r a n c h R e l a t i v e
+**
+**************************************************************************/
+void vmBranchRelative(FICL_VM *pVM, int offset)
+{
+ pVM->ip += offset;
+ return;
+}
+
+
+/**************************************************************************
+ v m C r e a t e
+** Creates a virtual machine either from scratch (if pVM 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)
+{
+ if (pVM == NULL)
+ {
+ pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
+ assert (pVM);
+ memset(pVM, 0, sizeof (FICL_VM));
+ }
+
+ if (pVM->pStack)
+ stackDelete(pVM->pStack);
+ pVM->pStack = stackCreate(nPStack);
+
+ if (pVM->rStack)
+ stackDelete(pVM->rStack);
+ pVM->rStack = stackCreate(nRStack);
+
+#if FICL_WANT_FLOAT
+ if (pVM->fStack)
+ stackDelete(pVM->fStack);
+ pVM->fStack = stackCreate(nPStack);
+#endif
+
+ pVM->textOut = ficlTextOut;
+
+ vmReset(pVM);
+ return pVM;
+}
+
+
+/**************************************************************************
+ v m D e l e t e
+** Free all memory allocated to the specified VM and its subordinate
+** structures.
+**************************************************************************/
+void vmDelete (FICL_VM *pVM)
+{
+ if (pVM)
+ {
+ ficlFree(pVM->pStack);
+ ficlFree(pVM->rStack);
+#if FICL_WANT_FLOAT
+ ficlFree(pVM->fStack);
+#endif
+ ficlFree(pVM);
+ }
+
+ 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
+** to complete. This does not happen until control reaches ficlExec
+**************************************************************************/
+void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
+{
+ pVM->runningWord = pWord;
+ pWord->code(pVM);
+ return;
+}
+
+
+/**************************************************************************
+ v m I n n e r L o o p
+** the mysterious inner interpreter...
+** This loop is the address interpreter that makes colon definitions
+** work. Upon entry, it assumes that the IP points to an entry in
+** a definition (the body of a colon word). It runs one word at a time
+** 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)
+{
+ M_INNER_LOOP(pVM);
+}
+#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;
+ }
+ }
+
+ return;
+}
+#endif
+
+
+
+/**************************************************************************
+ v m G e t D i c t
+** Returns the address dictionary for this VM's system
+**************************************************************************/
+FICL_DICT *vmGetDict(FICL_VM *pVM)
+{
+ assert(pVM);
+ return pVM->pSys->dp;
+}
+
+
+/**************************************************************************
+ 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.
+**
+** Returns the address of the first unused character in the dest buffer.
+**************************************************************************/
+char *vmGetString(FICL_VM *pVM, FICL_STRING *spDest, char delimiter)
+{
+ STRINGINFO si = vmParseStringEx(pVM, delimiter, 0);
+
+ if (SI_COUNT(si) > FICL_STRING_MAX)
+ {
+ SI_SETLEN(si, FICL_STRING_MAX);
+ }
+
+ strncpy(spDest->text, SI_PTR(si), SI_COUNT(si));
+ spDest->text[SI_COUNT(si)] = '\0';
+ spDest->count = (FICL_COUNT)SI_COUNT(si);
+
+ return spDest->text + SI_COUNT(si) + 1;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d
+** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
+** non-zero length.
+**************************************************************************/
+STRINGINFO vmGetWord(FICL_VM *pVM)
+{
+ STRINGINFO si = vmGetWord0(pVM);
+
+ if (SI_COUNT(si) == 0)
+ {
+ vmThrow(pVM, VM_RESTART);
+ }
+
+ return si;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d 0
+** Skip leading whitespace and parse a space delimited word from the tib.
+** Returns the start address and length of the word. Updates the tib
+** to reflect characters consumed, including the trailing delimiter.
+** If there's nothing of interest in the tib, returns zero. This function
+** does not use vmParseString because it uses isspace() rather than a
+** single delimiter character.
+**************************************************************************/
+STRINGINFO vmGetWord0(FICL_VM *pVM)
+{
+ char *pSrc = vmGetInBuf(pVM);
+ char *pEnd = vmGetInBufEnd(pVM);
+ STRINGINFO si;
+ FICL_UNS count = 0;
+ char ch = 0;
+
+ pSrc = skipSpace(pSrc, pEnd);
+ SI_SETPTR(si, pSrc);
+
+/*
+ for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
+ {
+ count++;
+ }
+*/
+
+ /* Changed to make Purify happier. --lch */
+ for (;;)
+ {
+ if (pEnd == pSrc)
+ break;
+ ch = *pSrc;
+ if (isspace(ch))
+ break;
+ count++;
+ pSrc++;
+ }
+
+ SI_SETLEN(si, count);
+
+ if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */
+ pSrc++;
+
+ vmUpdateTib(pVM, pSrc);
+
+ return si;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d T o P a d
+** Does vmGetWord and copies the result to the pad as a NULL terminated
+** 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)
+{
+ STRINGINFO si;
+ char *cp = (char *)pVM->pad;
+ si = vmGetWord(pVM);
+
+ if (SI_COUNT(si) > nPAD)
+ SI_SETLEN(si, nPAD);
+
+ strncpy(cp, SI_PTR(si), SI_COUNT(si));
+ cp[SI_COUNT(si)] = '\0';
+ return (int)(SI_COUNT(si));
+}
+
+
+/**************************************************************************
+ v m P a r s e S t r i n g
+** Parses a string out of the input buffer using the delimiter
+** specified. Skips leading delimiters, marks the start of the string,
+** and counts characters to the next delimiter it encounters. It then
+** updates the vm input buffer to consume all these chars, including the
+** trailing delimiter.
+** Returns the address and length of the parsed string, not including the
+** trailing delimiter.
+**************************************************************************/
+STRINGINFO vmParseString(FICL_VM *pVM, char delim)
+{
+ return vmParseStringEx(pVM, delim, 1);
+}
+
+STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
+{
+ STRINGINFO si;
+ char *pSrc = vmGetInBuf(pVM);
+ char *pEnd = vmGetInBufEnd(pVM);
+ char ch;
+
+ if (fSkipLeading)
+ { /* skip lead delimiters */
+ while ((pSrc != pEnd) && (*pSrc == delim))
+ pSrc++;
+ }
+
+ SI_SETPTR(si, pSrc); /* mark start of text */
+
+ for (ch = *pSrc; (pSrc != pEnd)
+ && (ch != delim)
+ && (ch != '\r')
+ && (ch != '\n'); ch = *++pSrc)
+ {
+ ; /* find next delimiter or end of line */
+ }
+
+ /* set length of result */
+ SI_SETLEN(si, pSrc - SI_PTR(si));
+
+ if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
+ pSrc++;
+
+ vmUpdateTib(pVM, pSrc);
+ return si;
+}
+
+
+/**************************************************************************
+ v m P o p
+**
+**************************************************************************/
+CELL vmPop(FICL_VM *pVM)
+{
+ return stackPop(pVM->pStack);
+}
+
+
+/**************************************************************************
+ v m P u s h
+**
+**************************************************************************/
+void vmPush(FICL_VM *pVM, CELL c)
+{
+ stackPush(pVM->pStack, c);
+ return;
+}
+
+
+/**************************************************************************
+ v m P o p I P
+**
+**************************************************************************/
+void vmPopIP(FICL_VM *pVM)
+{
+ pVM->ip = (IPTYPE)(stackPopPtr(pVM->rStack));
+ return;
+}
+
+
+/**************************************************************************
+ v m P u s h I P
+**
+**************************************************************************/
+void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
+{
+ stackPushPtr(pVM->rStack, (void *)pVM->ip);
+ pVM->ip = newIP;
+ return;
+}
+
+
+/**************************************************************************
+ 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)
+{
+ if (pSaveTib)
+ {
+ *pSaveTib = pVM->tib;
+ }
+
+ pVM->tib.cp = text;
+ pVM->tib.end = text + nChars;
+ pVM->tib.index = 0;
+}
+
+
+void vmPopTib(FICL_VM *pVM, TIB *pTib)
+{
+ if (pTib)
+ {
+ pVM->tib = *pTib;
+ }
+ return;
+}
+
+
+/**************************************************************************
+ 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;
+ return;
+}
+
+
+/**************************************************************************
+ v m R e s e t
+**
+**************************************************************************/
+void vmReset(FICL_VM *pVM)
+{
+ vmQuit(pVM);
+ stackReset(pVM->pStack);
+#if FICL_WANT_FLOAT
+ stackReset(pVM->fStack);
+#endif
+ pVM->base = 10;
+ return;
+}
+
+
+/**************************************************************************
+ v m S e t T e x t O u t
+** 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)
+{
+ if (textOut)
+ pVM->textOut = textOut;
+ else
+ pVM->textOut = ficlTextOut;
+
+ 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);
+
+ return;
+}
+
+
+/**************************************************************************
+ v m T h r o w
+**
+**************************************************************************/
+void vmThrow(FICL_VM *pVM, int except)
+{
+ if (pVM->pState)
+ longjmp(*(pVM->pState), except);
+}
+
+
+void vmThrowErr(FICL_VM *pVM, 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);
+}
+
+
+/**************************************************************************
+ w o r d I s I m m e d i a t e
+**
+**************************************************************************/
+int wordIsImmediate(FICL_WORD *pFW)
+{
+ return ((pFW != NULL) && (pFW->flags & FW_IMMEDIATE));
+}
+
+
+/**************************************************************************
+ w o r d I s C o m p i l e O n l y
+**
+**************************************************************************/
+int wordIsCompileOnly(FICL_WORD *pFW)
+{
+ return ((pFW != NULL) && (pFW->flags & FW_COMPILE));
+}
+
+
+/**************************************************************************
+ s t r r e v
+**
+**************************************************************************/
+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;
+
+ 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
+**
+**************************************************************************/
+char digit_to_char(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 isPowerOfTwo(FICL_UNS u)
+{
+ int i = 1;
+ FICL_UNS t = 2;
+
+ for (; ((t <= u) && (t != 0)); i++, t <<= 1)
+ {
+ if (u == t)
+ return i;
+ }
+
+ return 0;
+}
+
+
+/**************************************************************************
+ l t o a
+**
+**************************************************************************/
+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)
+ {
+ FICL_UNS v = (FICL_UNS) value;
+ FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
+ while (v)
+ {
+ *cp++ = digits[v & mask];
+ v >>= pwr;
+ }
+ }
+ else
+ {
+ 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;
+ }
+ }
+
+ if (sign)
+ *cp++ = '-';
+
+ *cp++ = '\0';
+
+ return strrev(string);
+}
+
+
+/**************************************************************************
+ 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;
+
+ while (ud.lo)
+ {
+ result = ficlLongDiv(ud, (FICL_UNS)radix);
+ ud.lo = result.quot;
+ *cp++ = digits[result.rem];
+ }
+ }
+
+ *cp++ = '\0';
+
+ return strrev(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 *caseFold(char *cp)
+{
+ char *oldCp = cp;
+
+ while (*cp)
+ {
+ if (isupper(*cp))
+ *cp = (char)tolower(*cp);
+ cp++;
+ }
+
+ return oldCp;
+}
+
+
+/**************************************************************************
+ 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)
+{
+ int i = 0;
+
+ for (; 0 < count; ++cp1, ++cp2, --count)
+ {
+ i = tolower(*cp1) - tolower(*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 *skipSpace(char *cp, char *end)
+{
+ assert(cp);
+
+ while ((cp != end) && isspace(*cp))
+ cp++;
+
+ return cp;
+}
+
+
diff --git a/stand/ficl/words.c b/stand/ficl/words.c
new file mode 100644
index 0000000..eee6fe9
--- /dev/null
+++ b/stand/ficl/words.c
@@ -0,0 +1,5208 @@
+/*******************************************************************
+** 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/05 07:21:34 jsadler 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.
+*/
+
+/* $FreeBSD$ */
+
+#ifdef TESTMAIN
+#include <stdlib.h>
+#include <stdio.h>
+#include <ctype.h>
+#include <fcntl.h>
+#else
+#include <stand.h>
+#endif
+#include <string.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);
+
+ dictCheckThreshold(dp);
+
+ 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;
+
+ FICL_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 = strtol(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_FALSE)
+ {
+ 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, (uintptr_t)*(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, (uintptr_t)*(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 "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 (int)FICL_TRUE;
+ }
+ }
+
+ else /* (pVM->state == COMPILE) */
+ {
+ if (tempFW != NULL)
+ {
+ if (wordIsImmediate(tempFW))
+ {
+ vmExecute(pVM, tempFW);
+ }
+ else
+ {
+ dictAppendCell(dp, LVALUEtoCELL(tempFW));
+ }
+ return (int)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, (uintptr_t)*(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, (uintptr_t)*(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)
+{
+ FICL_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);
+
+ dictCheckThreshold(dp);
+
+ 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 = stackPopUNS(pVM->pStack);
+ char *cp = stackPopPtr(pVM->pStack);
+ char *pDest = (char *)ficlMalloc(count + 1);
+
+ /*
+ ** 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 (!pDest)
+ vmThrowErr(pVM, "Error: out of memory");
+
+ strncpy(pDest, cp, count);
+ pDest[count] = '\0';
+
+ vmTextOut(pVM, pDest, 0);
+
+ ficlFree(pDest);
+ 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 a 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;
+}
+
+
+#ifdef TESTMAIN
+/**************************************************************************
+** r a n d o m
+** FICL-specific
+**************************************************************************/
+static void ficlRandom(FICL_VM *pVM)
+{
+ PUSHUNS(random());
+}
+
+
+/**************************************************************************
+** s e e d - r a n d o m
+** FICL-specific
+**************************************************************************/
+static void ficlSeedRandom(FICL_VM *pVM)
+{
+ srandom(POPUNS());
+}
+#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 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
+#ifdef TESTMAIN
+ dictAppendWord(dp, "random", ficlRandom, FW_DEFAULT);
+ dictAppendWord(dp, "seed-random",ficlSeedRandom,FW_DEFAULT);
+#endif
+
+ /*
+ ** 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;
+}
OpenPOWER on IntegriCloud