diff options
Diffstat (limited to 'stand/ficl')
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; +} |