ref: 9c2fa11a00741c380ff085eafda22170a98d9e01
parent: 7393a9a5e8453bbc7c8b767a6af41b463a9ca34a
author: asau <asau@ficl.sf.net>
date: Thu Aug 12 08:57:23 CDT 2010
Merging FICL 4.0.31.
--- a/ficl.dsw
+++ b/ficl.dsw
@@ -3,7 +3,37 @@
###############################################################################
-Project: "ficl"=.\ficl.dsp - Package Owner=<4>
+Project: "ficldll"=.\ficldll.dsp - Package Owner=<4>
+
+Package=<5>
+{{{+}}}
+
+Package=<4>
+{{{+ Begin Project Dependency
+ Project_Dep_Name ficllib
+ End Project Dependency
+}}}
+
+###############################################################################
+
+Project: "ficlexe"=.\ficlexe.dsp - Package Owner=<4>
+
+Package=<5>
+{{{+}}}
+
+Package=<4>
+{{{+ Begin Project Dependency
+ Project_Dep_Name ficllib
+ End Project Dependency
+}}}
+
+###############################################################################
+
+Project: "ficllib"=.\ficllib.dsp - Package Owner=<4>
Package=<5>
{{{--- a/ficl.h
+++ b/ficl.h
@@ -1,1114 +1,1859 @@
-/*******************************************************************
-** 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.
-*/
-
-#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 */
-#include <stdio.h>
-
-/*
-** 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.02"
-#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[1]; /* Base of dictionary memory */
-};
-
-void *alignPtr(void *ptr);
-void dictAbortDefinition(FICL_DICT *pDict);
-void dictAlign (FICL_DICT *pDict);
-int dictAllot (FICL_DICT *pDict, int n);
-int dictAllotCells (FICL_DICT *pDict, int nCells);
-void dictAppendCell (FICL_DICT *pDict, CELL c);
-void dictAppendChar (FICL_DICT *pDict, char c);
-FICL_WORD *dictAppendWord (FICL_DICT *pDict,
- char *name,
- FICL_CODE pCode,
- UNS8 flags);
-FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
- STRINGINFO si,
- FICL_CODE pCode,
- UNS8 flags);
-void dictAppendUNS (FICL_DICT *pDict, FICL_UNS u);
-int dictCellsAvail (FICL_DICT *pDict);
-int dictCellsUsed (FICL_DICT *pDict);
-void dictCheck (FICL_DICT *pDict, FICL_VM *pVM, int n);
-FICL_DICT *dictCreate(unsigned nCELLS);
-FICL_DICT *dictCreateHashed(unsigned nCells, unsigned nHash);
-FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets);
-void dictDelete (FICL_DICT *pDict);
-void dictEmpty (FICL_DICT *pDict, unsigned nHash);
-#if FICL_WANT_FLOAT
-void dictHashSummary(FICL_VM *pVM);
-#endif
-int dictIncludes (FICL_DICT *pDict, void *p);
-FICL_WORD *dictLookup (FICL_DICT *pDict, STRINGINFO si);
-#if FICL_WANT_LOCALS
-FICL_WORD *ficlLookupLoc (FICL_SYSTEM *pSys, STRINGINFO si);
-#endif
-void dictResetSearchOrder(FICL_DICT *pDict);
-void dictSetFlags (FICL_DICT *pDict, UNS8 set, UNS8 clr);
-void dictSetImmediate(FICL_DICT *pDict);
-void dictUnsmudge (FICL_DICT *pDict);
-CELL *dictWhere (FICL_DICT *pDict);
-
-
-/*
-** 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 *pIfParen;
- FICL_WORD *pInterpret;
- FICL_WORD *pLitParen;
- FICL_WORD *pTwoLitParen;
- FICL_WORD *pLoopParen;
- FICL_WORD *pPLoopParen;
- FICL_WORD *pQDoParen;
- FICL_WORD *pSemiParen;
- FICL_WORD *pStore;
- FICL_WORD *pCStringLit;
- FICL_WORD *pStringLit;
-
-#if FICL_WANT_LOCALS
- FICL_WORD *pGetLocalParen;
- FICL_WORD *pGet2LocalParen;
- FICL_WORD *pGetLocal0;
- FICL_WORD *pGetLocal1;
- FICL_WORD *pToLocalParen;
- FICL_WORD *pTo2LocalParen;
- FICL_WORD *pToLocal0;
- FICL_WORD *pToLocal1;
- FICL_WORD *pLinkParen;
- FICL_WORD *pUnLinkParen;
- FICL_INT nLocals;
- CELL *pMarkLocals;
-#endif
-
- FICL_BREAKPOINT bpStep;
-};
-
-struct ficl_system_info
-{
- int size; /* 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);
-
-/*
-** 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,
- PLOOP,
- PRIMITIVE,
- QDO,
- STRINGLIT,
- CSTRINGLIT,
-#if FICL_WANT_USER
- USER,
-#endif
- VARIABLE,
-} WORDKIND;
-
-WORDKIND ficlWordClassify(FICL_WORD *pFW);
-
-
-
-/*
-** Used with File-Access wordset.
-*/
-#define FICL_FAM_READ 1
-#define FICL_FAM_WRITE 2
-#define FICL_FAM_APPEND 4
-#define FICL_FAM_BINARY 8
-
-#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND))
-
-
-typedef struct ficlFILE
-{
- FILE *f;
- char filename[256];
-} ficlFILE;
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* __FICL_H__ */
+/*******************************************************************
+** 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.19 2010/08/12 13:57:22 asau Exp $
+********************************************************************
+**
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#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 expects to be at the center
+** of the system, requesting input at its convenience. Each Ficl virtual
+** machine can be bound to a different I/O channel, and is independent
+** of all others in in the same address space except that all virtual
+** 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 ficlCallbackDefaultTextOut to work with your
+** operating system. Finally, use testmain.c as a guide to installing the
+** Ficl system and one or more virtual machines into your code. You do not
+** need to include testmain.c in your build.
+**
+** T o D o L i s t
+**
+** 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
+*/
+
+
+#ifdef __cplusplus
+extern "C" {+#endif
+
+#include <limits.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+/*
+** Put all your local defines in ficllocal.h,
+** rather than editing the makefile/project/etc.
+** ficllocal.h will always ship as an inert file.
+*/
+#include "ficllocal.h"
+
+
+
+
+#if defined(FICL_ANSI)
+ #include "ficlplatform/ansi.h"
+#elif defined(_WIN32)
+ #include "ficlplatform/win32.h"
+#elif defined (FREEBSD_ALPHA)
+ #include "ficlplatform/alpha.h"
+#elif defined(linux)
+ #include "ficlplatform/unix.h"
+#endif /* platform */
+
+
+
+/*
+**
+** B U I L D C O N T R O L S
+**
+** First, the FICL_WANT_* settings.
+** These are all optional settings that you may or may not
+** want Ficl to use.
+**
+*/
+
+/*
+** FICL_WANT_MINIMAL
+** If set to nonzero, build the smallest possible Ficl interpreter.
+*/
+#if !defined(FICL_WANT_MINIMAL)
+#define FICL_WANT_MINIMAL (0)
+#endif
+
+#if FICL_WANT_MINIMAL
+#define FICL_WANT_SOFTWORDS (0)
+#define FICL_WANT_FILE (0)
+#define FICL_WANT_FLOAT (0)
+#define FICL_WANT_USER (0)
+#define FICL_WANT_LOCALS (0)
+#define FICL_WANT_DEBUGGER (0)
+#define FICL_WANT_OOP (0)
+#define FICL_WANT_PLATFORM (0)
+#define FICL_WANT_MULTITHREADED (0)
+#define FICL_WANT_EXTENDED_PREFIX (0)
+
+#define FICL_ROBUST (0)
+
+#endif /* FICL_WANT_MINIMAL */
+
+
+/*
+** FICL_WANT_PLATFORM
+** Includes words defined in ficlCompilePlatform
+** (see ficlplatform/win32.c and ficlplatform/unix.c for example)
+*/
+#if !defined (FICL_WANT_PLATFORM)
+#define FICL_WANT_PLATFORM (0)
+#endif /* FICL_WANT_PLATFORM */
+
+
+/*
+** FICL_WANT_COMPATIBILITY
+** Changes Ficl 4 at compile-time so it is source-compatible
+** with the Ficl 3 API. If you are a new user to Ficl you
+** don't need to worry about this setting; if you are upgrading
+** from a pre-4.0 version of Ficl, see doc/upgrading.html for
+** more information.
+*/
+#if !defined FICL_WANT_COMPATIBILITY
+#define FICL_WANT_COMPATIBILITY (0)
+#endif /* !defined FICL_WANT_COMPATIBILITY */
+
+
+
+/*
+** FICL_WANT_LZ_SOFTCORE
+** If nonzero, the softcore words are stored compressed
+** with patent-unencumbered Lempel-Ziv '77 compression.
+** This results in a smaller Ficl interpreter, and adds
+** only a *tiny* runtime speed hit.
+**
+** As of version 4.0.27, all the runtime code for the decompressor
+** is 688 bytes on a single-threaded release build, but saves 14179
+** bytes of data. That's a net savings of over 13k! Plus, it makes
+** the resulting executable harder to hack :)
+**
+** On my 850MHz Duron machine, decompression took 0.00384 seconds
+** if QueryPerformanceCounter() can be believed... it claims that it
+** took 13765 cycles to complete, and that my machine runs 3579545
+** cycles/second.
+**
+** Contributed by Larry Hastings.
+*/
+#if !defined (FICL_WANT_LZ_SOFTCORE)
+#define FICL_WANT_LZ_SOFTCORE (1)
+#endif /* FICL_WANT_LZ_SOFTCORE */
+
+
+/*
+** FICL_WANT_FILE
+** Includes the FILE and FILE-EXT wordset and associated code.
+** Turn this off if you do not have a file system!
+** Contributed by Larry Hastings
+*/
+#if !defined (FICL_WANT_FILE)
+#define FICL_WANT_FILE (1)
+#endif /* FICL_WANT_FILE */
+
+/*
+** FICL_WANT_FLOAT
+** Includes a floating point stack for the VM, and words to do float operations.
+** Contributed by Guy Carver
+*/
+#if !defined (FICL_WANT_FLOAT)
+#define FICL_WANT_FLOAT (1)
+#endif /* FICL_WANT_FLOAT */
+
+/*
+** FICL_WANT_DEBUGGER
+** Inludes a simple source level debugger
+*/
+#if !defined (FICL_WANT_DEBUGGER)
+#define FICL_WANT_DEBUGGER (1)
+#endif /* FICL_WANT_DEBUGGER */
+
+/*
+** FICL_EXTENDED_PREFIX
+** Enables a bunch of extra prefixes in prefix.c
+** and prefix.fr (if included as part of softcore.c)
+*/
+#if !defined FICL_WANT_EXTENDED_PREFIX
+#define FICL_WANT_EXTENDED_PREFIX (0)
+#endif /* FICL_WANT_EXTENDED_PREFIX */
+
+/*
+** FICL_WANT_USER
+** Enables user variables: per-instance variables bound to the VM.
+** Kind of like thread-local storage. Could be implemented in a
+** VM private dictionary, but I've chosen the lower overhead
+** approach of an array of CELLs instead.
+*/
+#if !defined FICL_WANT_USER
+#define FICL_WANT_USER (1)
+#endif /* FICL_WANT_USER */
+
+/*
+** FICL_WANT_LOCALS
+** Controls the creation of the LOCALS wordset
+** and a private dictionary for local variable compilation.
+*/
+#if !defined FICL_WANT_LOCALS
+#define FICL_WANT_LOCALS (1)
+#endif /* FICL_WANT_LOCALS */
+
+/*
+** FICL_WANT_OOP
+** Inludes object oriented programming support (in softwords)
+** OOP support requires locals and user variables!
+*/
+#if !defined (FICL_WANT_OOP)
+#define FICL_WANT_OOP ((FICL_WANT_LOCALS) && (FICL_WANT_USER))
+#endif /* FICL_WANT_OOP */
+
+/*
+** FICL_WANT_SOFTWORDS
+** Controls inclusion of all softwords in softcore.c.
+*/
+#if !defined (FICL_WANT_SOFTWORDS)
+#define FICL_WANT_SOFTWORDS (1)
+#endif /* FICL_WANT_SOFTWORDS */
+
+/*
+** FICL_WANT_MULTITHREADED
+** Enables dictionary mutual exclusion wia the
+** ficlLockDictionary() system dependent function.
+**
+** Note: this implementation is experimental and poorly
+** tested. Further, it's unnecessary unless you really
+** intend to have multiple SESSIONS (poor choice of name
+** on my part) - that is, threads that modify the dictionary
+** at the same time.
+*/
+#if !defined FICL_WANT_MULTITHREADED
+#define FICL_WANT_MULTITHREADED (0)
+#endif /* FICL_WANT_MULTITHREADED */
+
+
+/*
+** FICL_WANT_OPTIMIZE
+** Do you want to optimize for size, or for speed?
+** Note that this doesn't affect Ficl very much one way
+** or the other at the moment.
+** Contributed by Larry Hastings
+*/
+#define FICL_OPTIMIZE_FOR_SPEED (1)
+#define FICL_OPTIMIZE_FOR_SIZE (2)
+#if !defined (FICL_WANT_OPTIMIZE)
+#define FICL_WANT_OPTIMIZE FICL_OPTIMIZE_FOR_SPEED
+#endif /* FICL_WANT_OPTIMIZE */
+
+
+/*
+** FICL_WANT_VCALL
+** Ficl OO support for calling vtable methods. Win32 only.
+** Contributed by Guy Carver
+*/
+#if !defined (FICL_WANT_VCALL)
+#define FICL_WANT_VCALL (0)
+#endif /* FICL_WANT_VCALL */
+
+
+
+/*
+** P L A T F O R M S E T T I N G S
+**
+** The FICL_PLATFORM_* settings.
+** These indicate attributes about the local platform.
+*/
+
+
+/*
+** FICL_PLATFORM_OS
+** String constant describing the current hardware architecture.
+*/
+#if !defined (FICL_PLATFORM_ARCHITECTURE)
+#define FICL_PLATFORM_ARCHITECTURE "unknown"
+#endif
+
+/*
+** FICL_PLATFORM_OS
+** String constant describing the current operating system.
+*/
+#if !defined (FICL_PLATFORM_OS)
+#define FICL_PLATFORM_OS "unknown"
+#endif
+
+/*
+** FICL_PLATFORM_HAS_2INTEGER
+** Indicates whether or not the current architecture
+** supports a native double-width integer type.
+** If you set this to 1 in your ficlplatform/*.h file,
+** you *must* create typedefs for the following two types:
+** ficl2Unsigned
+** ficl2Integer
+** If this is set to 0, Ficl will implement double-width
+** integer math in C, which is both bigger *and* slower
+** (the double whammy!). Make sure your compiler really
+** genuinely doesn't support native double-width integers
+** before setting this to 0.
+*/
+#if !defined (FICL_PLATFORM_HAS_2INTEGER)
+#define FICL_PLATFORM_HAS_2INTEGER (0)
+#endif
+
+/*
+** FICL_PLATFORM_HAS_FTRUNCATE
+** Indicates whether or not the current platform provides
+** the ftruncate() function (available on most UNIXes).
+** This function is necessary to provide the complete
+** File-Access wordset.
+**
+** If your platform does not have ftruncate() per se,
+** but does have some method of truncating files, you
+** should be able to implement ftruncate() yourself and
+** set this constant to 1. For an example of this see
+** "ficlplatform/win32.c".
+*/
+#if !defined (FICL_PLATFORM_HAS_FTRUNCATE)
+#define FICL_PLATFORM_HAS_FTRUNCATE (0)
+#endif
+
+
+/*
+** FICL_PLATFORM_INLINE
+** Must be defined, should be a function prototype type-modifying
+** keyword that makes a function "inline". Ficl does not assume
+** that the local platform supports inline functions; it therefore
+** only uses "inline" where "static" would also work, and uses "static"
+** in the absence of another keyword.
+*/
+#if !defined FICL_PLATFORM_INLINE
+#define FICL_PLATFORM_INLINE static
+#endif /* !defined FICL_PLATFORM_INLINE */
+
+/*
+** FICL_PLATFORM_EXTERN
+** Must be defined, should be a keyword used to declare
+** a function prototype as being a genuine prototype.
+** You should only have to fiddle with this setting if
+** you're not using an ANSI-compliant compiler, in which
+** case, good luck!
+*/
+#if !defined FICL_PLATFORM_EXTERN
+#define FICL_PLATFORM_EXTERN extern
+#endif /* !defined FICL_PLATFORM_EXTERN */
+
+
+
+/*
+** FICL_PLATFORM_BASIC_TYPES
+**
+** If not defined yet,
+*/
+#if !defined(FICL_PLATFORM_BASIC_TYPES)
+typedef char ficlInteger8;
+typedef unsigned char ficlUnsigned8;
+typedef short ficlInteger16;
+typedef unsigned short ficlUnsigned16;
+typedef long ficlInteger32;
+typedef unsigned long ficlUnsigned32;
+
+typedef ficlInteger32 ficlInteger;
+typedef ficlUnsigned32 ficlUnsigned;
+typedef float ficlFloat;
+
+#endif /* !defined(FICL_PLATFORM_BASIC_TYPES) */
+
+
+
+
+
+
+
+/*
+** FICL_ROBUST enables bounds checking of stacks and the dictionary.
+** This will detect stack over and underflows and dictionary overflows.
+** Any exceptional condition will result in an assertion failure.
+** (As generated by the ANSI assert macro)
+** FICL_ROBUST == 1 --> stack checking in the outer interpreter
+** FICL_ROBUST == 2 also enables checking in many primitives
+*/
+
+#if !defined FICL_ROBUST
+#define FICL_ROBUST (2)
+#endif /* FICL_ROBUST */
+
+
+
+/*
+** FICL_DEFAULT_STACK_SIZE Specifies the default size (in CELLs) of
+** a new virtual machine's stacks, unless overridden at
+** create time.
+*/
+#if !defined FICL_DEFAULT_STACK_SIZE
+#define FICL_DEFAULT_STACK_SIZE (128)
+#endif
+
+/*
+** FICL_DEFAULT_DICTIONARY_SIZE specifies the number of ficlCells to allocate
+** for the system dictionary by default. The value
+** can be overridden at startup time as well.
+*/
+#if !defined FICL_DEFAULT_DICTIONARY_SIZE
+#define FICL_DEFAULT_DICTIONARY_SIZE (12288)
+#endif
+
+/*
+** FICL_DEFAULT_ENVIRONMENT_SIZE specifies the number of cells
+** to allot for the environment-query dictionary.
+*/
+#if !defined FICL_DEFAULT_ENVIRONMENT_SIZE
+#define FICL_DEFAULT_ENVIRONMENT_SIZE (512)
+#endif
+
+/*
+** FICL_MAX_WORDLISTS specifies the maximum number of wordlists in
+** the dictionary search order. See Forth DPANS sec 16.3.3
+** (file://dpans16.htm#16.3.3)
+*/
+#if !defined FICL_MAX_WORDLISTS
+#define FICL_MAX_WORDLISTS (16)
+#endif
+
+/*
+** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure
+** that stores pointers to parser extension functions. I would never expect to have
+** more than 8 of these, so that's the default limit. Too many of these functions
+** will probably exact a nasty performance penalty.
+*/
+#if !defined FICL_MAX_PARSE_STEPS
+#define FICL_MAX_PARSE_STEPS (8)
+#endif
+
+/*
+** Maximum number of local variables per definition.
+** This only affects the size of the locals dictionary,
+** and there's only one per entire ficlSystem, so it
+** doesn't make sense to be a piker here.
+*/
+#if (!defined(FICL_MAX_LOCALS)) && FICL_WANT_LOCALS
+#define FICL_MAX_LOCALS (64)
+#endif
+
+/*
+** The pad is a small scratch area for text manipulation. ANS Forth
+** requires it to hold at least 84 characters.
+*/
+#if !defined FICL_PAD_SIZE
+#define FICL_PAD_SIZE (256)
+#endif
+
+/*
+** ANS Forth requires that a word's name contain {1..31} characters.+*/
+#if !defined FICL_NAME_LENGTH
+#define FICL_NAME_LENGTH (31)
+#endif
+
+/*
+** Default size of hash table. For most uniform
+** performance, use a prime number!
+*/
+#if !defined FICL_HASH_SIZE
+ #define FICL_HASH_SIZE (241)
+#endif
+
+
+/*
+** Default number of USER flags.
+*/
+#if (!defined(FICL_USER_CELLS)) && FICL_WANT_USER
+#define FICL_USER_CELLS (16)
+#endif
+
+
+
+
+
+
+/*
+** Forward declarations... read on.
+*/
+struct ficlWord;
+typedef struct ficlWord ficlWord;
+struct ficlVm;
+typedef struct ficlVm ficlVm;
+struct ficlDictionary;
+typedef struct ficlDictionary ficlDictionary;
+struct ficlSystem;
+typedef struct ficlSystem ficlSystem;
+struct ficlSystemInformation;
+typedef struct ficlSystemInformation ficlSystemInformation;
+struct ficlCallback;
+typedef struct ficlCallback ficlCallback;
+struct ficlCountedString;
+typedef struct ficlCountedString ficlCountedString;
+struct ficlString;
+typedef struct ficlString ficlString;
+
+
+/*
+** System dependent routines:
+** Edit the implementations in your appropriate ficlplatform/*.c to be
+** compatible with your runtime environment.
+**
+** ficlCallbackDefaultTextOut sends a zero-terminated string to the
+** default output device - used for system error messages.
+**
+** ficlMalloc(), ficlRealloc() and ficlFree() have the same semantics
+** as the functions malloc(), realloc(), and free() from the standard C library.
+*/
+FICL_PLATFORM_EXTERN void ficlCallbackDefaultTextOut(ficlCallback *callback, char *text);
+FICL_PLATFORM_EXTERN void *ficlMalloc (size_t size);
+FICL_PLATFORM_EXTERN void ficlFree (void *p);
+FICL_PLATFORM_EXTERN void *ficlRealloc(void *p, size_t size);
+
+
+
+
+
+
+/*
+** the Good Stuff starts here...
+*/
+#define FICL_VERSION "4.0.31"
+
+#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)
+
+
+#if !defined FICL_IGNORE /* Macro to silence unused param warnings */
+#define FICL_IGNORE(x) &x
+#endif /* !defined FICL_IGNORE */
+
+
+
+
+#if !defined NULL
+#define NULL ((void *)0)
+#endif
+
+
+/*
+** Jiggery-pokery for the FICL_WANT_COMPATIBILITY compatibility layer.
+** Even if you're not using it, compatibility.c won't compile properly
+** unless FICL_WANT_COMPATIBILITY is turned on. Hence, we force it to
+** always be turned on.
+*/
+#ifdef FICL_FORCE_COMPATIBILITY
+#undef FICL_WANT_COMPATIBILITY
+#define FICL_WANT_COMPATIBILITY (1)
+#endif /* FICL_FORCE_COMPATIBILITY */
+
+
+
+
+
+/*
+** 2integer structures
+*/
+#if FICL_PLATFORM_HAS_2INTEGER
+
+#define FICL_2INTEGER_SET(high, low, doublei) ((doublei) = (ficl2Integer)(((ficlUnsigned)(low)) | (((ficl2Integer)(high)) << FICL_BITS_PER_CELL)))
+#define FICL_2INTEGER_TO_2UNSIGNED(doublei) ((ficl2Unsigned)(doublei))
+
+#define FICL_2UNSIGNED_SET(high, low, doubleu) ((doubleu) = ((ficl2Unsigned)(low)) | (((ficl2Unsigned)(high)) << FICL_BITS_PER_CELL))
+#define FICL_2UNSIGNED_GET_LOW(doubleu) ((ficlUnsigned)(doubleu & ((((ficl2Integer)1) << FICL_BITS_PER_CELL) - 1)))
+#define FICL_2UNSIGNED_GET_HIGH(doubleu) ((ficlUnsigned)(doubleu >> FICL_BITS_PER_CELL))
+#define FICL_2UNSIGNED_NOT_ZERO(doubleu) ((doubleu) != 0)
+#define FICL_2UNSIGNED_TO_2INTEGER(doubleu) ((ficl2Integer)(doubleu))
+
+#define FICL_INTEGER_TO_2INTEGER(i, doublei) ((doublei) = (i))
+#define FICL_UNSIGNED_TO_2UNSIGNED(u, doubleu) ((doubleu) = (u))
+
+#define ficl2IntegerIsNegative(doublei) ((doublei) < 0)
+#define ficl2IntegerNegate(doublei) (-(doublei))
+
+#define ficl2IntegerMultiply(x, y) (((ficl2Integer)(x)) * ((ficl2Integer)(y)))
+#define ficl2IntegerDecrement(x) (((ficl2Integer)(x)) - 1)
+
+#define ficl2UnsignedAdd(x, y) (((ficl2Unsigned)(x)) + ((ficl2Unsigned)(y)))
+#define ficl2UnsignedSubtract(x, y) (((ficl2Unsigned)(x)) - ((ficl2Unsigned)(y)))
+#define ficl2UnsignedMultiply(x, y) (((ficl2Unsigned)(x)) * ((ficl2Unsigned)(y)))
+#define ficl2UnsignedMultiplyAccumulate(u, mul, add) (((u) * (mul)) + (add))
+#define ficl2UnsignedArithmeticShiftLeft(x) ((x) << 1)
+#define ficl2UnsignedArithmeticShiftRight(x) ((x) >> 1)
+#define ficl2UnsignedCompare(x, y) ficl2UnsignedSubtract(x, y)
+#define ficl2UnsignedOr(x, y) ((x) | (y))
+
+#else /* FICL_PLATFORM_HAS_2INTEGER */
+
+typedef struct
+{+ ficlUnsigned high;
+ ficlUnsigned low;
+} ficl2Unsigned;
+
+typedef struct
+{+ ficlInteger high;
+ ficlInteger low;
+} ficl2Integer;
+
+
+#define FICL_2INTEGER_SET(hi, lo, doublei) { ficl2Integer x; x.low = (lo); x.high = (hi); (doublei) = x; }+#define FICL_2INTEGER_TO_2UNSIGNED(doublei) (*(ficl2Unsigned *)(&(doublei)))
+
+
+#define FICL_2UNSIGNED_SET(hi, lo, doubleu) { ficl2Unsigned x; x.low = (lo); x.high = (hi); (doubleu) = x; }+#define FICL_2UNSIGNED_GET_LOW(doubleu) ((doubleu).low)
+#define FICL_2UNSIGNED_GET_HIGH(doubleu) ((doubleu).high)
+#define FICL_2UNSIGNED_NOT_ZERO(doubleu) ((doubleu).high || (doubleu).low)
+#define FICL_2UNSIGNED_TO_2INTEGER(doubleu) (*(ficl2Integer *)(&(doubleu)))
+
+#define FICL_INTEGER_TO_2INTEGER(i, doublei) { ficlInteger __x = (ficlInteger)(i); FICL_2INTEGER_SET((__x < 0) ? -1L : 0, __x, doublei) }+#define FICL_UNSIGNED_TO_2UNSIGNED(u, doubleu) FICL_2UNSIGNED_SET(0, u, doubleu)
+
+
+FICL_PLATFORM_EXTERN int ficl2IntegerIsNegative(ficl2Integer x);
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerNegate(ficl2Integer x);
+
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerMultiply(ficlInteger x, ficlInteger y);
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerDecrement(ficl2Integer x);
+
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedAdd(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedSubtract(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedMultiply(ficlUnsigned x, ficlUnsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedMultiplyAccumulate(ficl2Unsigned u, ficlUnsigned mul, ficlUnsigned add);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedArithmeticShiftLeft( ficl2Unsigned x );
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedArithmeticShiftRight( ficl2Unsigned x );
+FICL_PLATFORM_EXTERN int ficl2UnsignedCompare(ficl2Unsigned x, ficl2Unsigned y);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficl2UnsignedOr( ficl2Unsigned x, ficl2Unsigned y );
+
+#endif /* FICL_PLATFORM_HAS_2INTEGER */
+
+FICL_PLATFORM_EXTERN ficl2Integer ficl2IntegerAbsoluteValue(ficl2Integer x);
+
+/*
+** These structures represent the result of division.
+*/
+typedef struct
+{+ ficl2Unsigned quotient;
+ ficlUnsigned remainder;
+} ficl2UnsignedQR;
+
+typedef struct
+{+ ficl2Integer quotient;
+ ficlInteger remainder;
+} ficl2IntegerQR;
+
+
+#define FICL_2INTEGERQR_TO_2UNSIGNEDQR(doubleiqr) (*(ficl2UnsignedQR *)(&(doubleiqr)))
+#define FICL_2UNSIGNEDQR_TO_2INTEGERQR(doubleuqr) (*(ficl2IntegerQR *)(&(doubleuqr)))
+
+/*
+** 64 bit integer math support routines: multiply two UNS32s
+** to get a 64 bit product, & divide the product by an UNS32
+** to get an UNS32 quotient and remainder. Much easier in asm
+** on a 32 bit CPU than in C, which usually doesn't support
+** the double length result (but it should).
+*/
+FICL_PLATFORM_EXTERN ficl2IntegerQR ficl2IntegerDivideFloored(ficl2Integer num, ficlInteger den);
+FICL_PLATFORM_EXTERN ficl2IntegerQR ficl2IntegerDivideSymmetric(ficl2Integer num, ficlInteger den);
+
+FICL_PLATFORM_EXTERN ficl2UnsignedQR ficl2UnsignedDivide(ficl2Unsigned q, ficlUnsigned y);
+
+
+
+
+
+
+/*
+** A ficlCell is the main storage type. It must be large enough
+** to contain a pointer or a scalar. In order to accommodate
+** 32 bit and 64 bit processors, use abstract types for int,
+** unsigned, and float.
+**
+** A ficlUnsigned, ficlInteger, and ficlFloat *MUST* be the same
+** size as a "void *" on the target system. (Sorry, but that's
+** a design constraint of FORTH.)
+*/
+typedef union ficlCell
+{+ ficlInteger i;
+ ficlUnsigned u;
+#if (FICL_WANT_FLOAT)
+ ficlFloat f;
+#endif
+ void *p;
+ void (*fn)(void);
+} ficlCell;
+
+
+#define FICL_BITS_PER_CELL (sizeof(ficlCell) * 8)
+
+/*
+** FICL_PLATFORM_ALIGNMENT is the number of bytes to which
+** the dictionary pointer address must be aligned. This value
+** is usually either 2 or 4, depending on the memory architecture
+** of the target system; 4 is safe on any 16 or 32 bit
+** machine. 8 would be appropriate for a 64 bit machine.
+*/
+#if !defined FICL_PLATFORM_ALIGNMENT
+#define FICL_PLATFORM_ALIGNMENT (4)
+#endif
+
+
+/*
+** FICL_LVALUE_TO_CELL does a little pointer trickery to cast any CELL sized
+** lvalue (informal definition: an expression whose result has an
+** address) to CELL. Remember that constants and casts are NOT
+** themselves lvalues!
+*/
+#define FICL_LVALUE_TO_CELL(v) (*(ficlCell *)&v)
+
+/*
+** PTRtoCELL is a cast through void * intended to satisfy the
+** most outrageously pedantic compiler... (I won't mention
+** its name)
+*/
+#define FICL_POINTER_TO_CELL(p) ((ficlCell *)(void *)p)
+
+/*
+** FORTH defines the "counted string" data type. This is
+** a "Pascal-style" string, where the first byte is an unsigned
+** count of characters, followed by the characters themselves.
+** The Ficl structure for this is ficlCountedString.
+** Ficl also often zero-terminates them so that they work with the
+** usual C runtime library string functions... strlen(), strcmp(),
+** and the like. (Belt & suspenders? You decide.)
+**
+** The problem is, this limits strings to 255 characters, which
+** can be a bit constricting to us wordy types. So FORTH only
+** uses counted strings for backwards compatibility, and all new
+** words are "c-addr u" style, where the address and length are
+** stored separately, and the length is a full unsigned "cell" size.
+** (For more on this trend, see DPANS94 section A.3.1.3.4.)
+** Ficl represents this with the ficlString structure. Note that
+** these are frequently *not* zero-terminated! Don't depend on
+** it--that way lies madness.
+*/
+
+struct ficlCountedString
+{+ ficlUnsigned8 length;
+ char text[1];
+};
+
+#define FICL_COUNTED_STRING_GET_LENGTH(cs) ((cs).length)
+#define FICL_COUNTED_STRING_GET_POINTER(cs) ((cs).text)
+
+#define FICL_COUNTED_STRING_MAX (256)
+#define FICL_POINTER_TO_COUNTED_STRING(p) ((ficlCountedString *)(void *)p)
+
+struct ficlString
+{+ ficlUnsigned length;
+ char *text;
+};
+
+
+#define FICL_STRING_GET_LENGTH(fs) ((fs).length)
+#define FICL_STRING_GET_POINTER(fs) ((fs).text)
+#define FICL_STRING_SET_LENGTH(fs, l) ((fs).length = (ficlUnsigned)(l))
+#define FICL_STRING_SET_POINTER(fs, p) ((fs).text = (char *)(p))
+#define FICL_STRING_SET_FROM_COUNTED_STRING(string, countedstring) \
+ {(string).text = (countedstring).text; (string).length = (countedstring).length;}+/*
+** Init a FICL_STRING from a pointer to a zero-terminated string
+*/
+#define FICL_STRING_SET_FROM_CSTRING(string, cstring) \
+ {(string).text = (cstring); (string).length = strlen(cstring);}+
+/*
+** Ficl uses this little structure to hold the address of
+** 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 ficlVm instead. (sobral)
+*/
+typedef struct
+{+ ficlInteger index;
+ char *end;
+ char *text;
+} ficlTIB;
+
+
+/*
+** 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
+{+ ficlUnsigned size; /* size of the stack, in cells */
+ ficlCell *frame; /* link reg for stack frame */
+ ficlCell *top; /* stack pointer */
+ ficlVm *vm; /* used for debugging */
+ char *name; /* used for debugging */
+ ficlCell base[1]; /* Top of stack */
+} ficlStack;
+
+/*
+** Stack methods... many map closely to required Forth words.
+*/
+FICL_PLATFORM_EXTERN ficlStack *ficlStackCreate (ficlVm *vm, char *name, unsigned nCells);
+FICL_PLATFORM_EXTERN void ficlStackDestroy (ficlStack *stack);
+FICL_PLATFORM_EXTERN int ficlStackDepth (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackDrop (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackFetch (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackGetTop (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPick (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN ficlCell ficlStackPop (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPush (ficlStack *stack, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlStackReset (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackRoll (ficlStack *stack, int n);
+FICL_PLATFORM_EXTERN void ficlStackSetTop (ficlStack *stack, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlStackStore (ficlStack *stack, int n, ficlCell c);
+
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN void ficlStackLink (ficlStack *stack, int nCells);
+FICL_PLATFORM_EXTERN void ficlStackUnlink (ficlStack *stack);
+#endif /* FICL_WANT_LOCALS */
+
+FICL_PLATFORM_EXTERN void *ficlStackPopPointer (ficlStack *stack);
+FICL_PLATFORM_EXTERN ficlUnsigned ficlStackPopUnsigned (ficlStack *stack);
+FICL_PLATFORM_EXTERN ficlInteger ficlStackPopInteger (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPushPointer (ficlStack *stack, void *ptr);
+FICL_PLATFORM_EXTERN void ficlStackPushUnsigned (ficlStack *stack, ficlUnsigned u);
+FICL_PLATFORM_EXTERN void ficlStackPushInteger (ficlStack *stack, ficlInteger i);
+
+#if (FICL_WANT_FLOAT)
+FICL_PLATFORM_EXTERN ficlFloat ficlStackPopFloat (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPushFloat (ficlStack *stack, ficlFloat f);
+#endif
+
+FICL_PLATFORM_EXTERN void ficlStackPush2Integer (ficlStack *stack, ficl2Integer i64);
+FICL_PLATFORM_EXTERN ficl2Integer ficlStackPop2Integer (ficlStack *stack);
+FICL_PLATFORM_EXTERN void ficlStackPush2Unsigned(ficlStack *stack, ficl2Unsigned u64);
+FICL_PLATFORM_EXTERN ficl2Unsigned ficlStackPop2Unsigned (ficlStack *stack);
+
+
+#if FICL_ROBUST >= 1
+FICL_PLATFORM_EXTERN void ficlStackCheck (ficlStack *stack, int popCells, int pushCells);
+#define FICL_STACK_CHECK(stack, popCells, pushCells) ficlStackCheck(stack, popCells, pushCells)
+#else /* FICL_ROBUST >= 1 */
+#define FICL_STACK_CHECK(stack, popCells, pushCells)
+#endif /* FICL_ROBUST >= 1 */
+
+typedef ficlInteger (*ficlStackWalkFunction)(void *constant, ficlCell *cell);
+FICL_PLATFORM_EXTERN void ficlStackWalk(ficlStack *stack, ficlStackWalkFunction callback, void *context, ficlInteger bottomToTop);
+FICL_PLATFORM_EXTERN void ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, void *context);
+
+
+typedef ficlWord **ficlIp; /* the VM's instruction pointer */
+typedef void (*ficlPrimitive)(ficlVm *vm);
+typedef void (*ficlOutputFunction)(ficlCallback *callback, char *text);
+
+
+/*
+** Each VM has a placeholder for an output function -
+** this makes it possible to have each VM do I/O
+** through a different device. If you specify no
+** ficlOutputFunction, it defaults to ficlCallbackDefaultTextOut.
+**
+** You can also set a specific handler just for errors.
+** If you don't specify one, it defaults to using textOut.
+*/
+
+struct ficlCallback
+{+ void *context;
+ ficlOutputFunction textOut;
+ ficlOutputFunction errorOut;
+ ficlSystem *system;
+ ficlVm *vm;
+};
+
+FICL_PLATFORM_EXTERN void ficlCallbackTextOut(ficlCallback *callback, char *text);
+FICL_PLATFORM_EXTERN void ficlCallbackErrorOut(ficlCallback *callback, char *text);
+
+/*
+** For backwards compatibility.
+*/
+typedef void (*ficlCompatibilityOutputFunction)(ficlVm *vm, char *text, int newline);
+FICL_PLATFORM_EXTERN void ficlCompatibilityTextOutCallback(ficlCallback *callback, char *text, ficlCompatibilityOutputFunction oldFunction);
+
+
+
+/*
+** Starting with Ficl 4.0, Ficl uses a "switch-threaded" inner loop,
+** where each primitive word is represented with a numeric constant,
+** and words are (more or less) arrays of these constants. In Ficl
+** these constants are an enumerated type called ficlInstruction.
+*/
+typedef enum
+{+ #define FICL_TOKEN(token, description) token,
+ #define FICL_INSTRUCTION_TOKEN(token, description, flags) token,
+ #include "ficltokens.h"
+ #undef FICL_TOKEN
+ #undef FICL_INSTRUCTION_TOKEN
+
+ ficlInstructionLast,
+
+ ficlInstructionFourByteTrick = 0x10000000
+} ficlInstruction;
+
+
+/*
+** 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
+*/
+
+
+struct ficlVm
+{+ ficlCallback callback;
+ ficlVm *link; /* Ficl keeps a VM list for simple teardown */
+ jmp_buf *exceptionHandler; /* crude exception mechanism... */
+ short restart; /* Set TRUE to restart runningWord */
+ ficlIp ip; /* instruction pointer */
+ ficlWord *runningWord;/* address of currently running word (often just *(ip-1) ) */
+ ficlUnsigned state; /* compiling or interpreting */
+ ficlUnsigned base; /* number conversion base */
+ ficlStack *dataStack;
+ ficlStack *returnStack; /* return stack */
+#if FICL_WANT_FLOAT
+ ficlStack *floatStack; /* float stack (optional) */
+#endif
+ ficlCell sourceId; /* -1 if EVALUATE, 0 if normal input, >0 if a file */
+ ficlTIB tib; /* address of incoming text string */
+#if FICL_WANT_USER
+ ficlCell user[FICL_USER_CELLS];
+#endif
+ char pad[FICL_PAD_SIZE]; /* the scratch area (see above) */
+#if FICL_WANT_COMPATIBILITY
+ ficlCompatibilityOutputFunction thunkedTextout;
+#endif /* FICL_WANT_COMPATIBILITY */
+};
+
+
+/*
+** Each VM operates in one of two non-error states: interpreting
+** 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 FICL_VM_STATE_INTERPRET (0)
+#define FICL_VM_STATE_COMPILE (1)
+
+
+/*
+** Exit codes for vmThrow
+*/
+#define FICL_VM_STATUS_INNER_EXIT (-256) /* tell ficlVmExecuteXT to exit inner loop */
+#define FICL_VM_STATUS_OUT_OF_TEXT (-257) /* hungry - normal exit */
+#define FICL_VM_STATUS_RESTART (-258) /* word needs more text to succeed -- re-run it */
+#define FICL_VM_STATUS_USER_EXIT (-259) /* user wants to quit */
+#define FICL_VM_STATUS_ERROR_EXIT (-260) /* interpreter found an error */
+#define FICL_VM_STATUS_BREAK (-261) /* debugger breakpoint */
+#define FICL_VM_STATUS_ABORT ( -1) /* like FICL_VM_STATUS_ERROR_EXIT -- abort */
+#define FICL_VM_STATUS_ABORTQ ( -2) /* like FICL_VM_STATUS_ERROR_EXIT -- abort" */
+#define FICL_VM_STATUS_QUIT ( -56) /* like FICL_VM_STATUS_ERROR_EXIT, but leave dataStack & base alone */
+
+
+FICL_PLATFORM_EXTERN void ficlVmBranchRelative(ficlVm *vm, int offset);
+FICL_PLATFORM_EXTERN ficlVm * ficlVmCreate (ficlVm *vm, unsigned nPStack, unsigned nRStack);
+FICL_PLATFORM_EXTERN void ficlVmDestroy (ficlVm *vm);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlVmGetDictionary(ficlVm *vm);
+FICL_PLATFORM_EXTERN char * ficlVmGetString (ficlVm *vm, ficlCountedString *spDest, char delimiter);
+FICL_PLATFORM_EXTERN ficlString ficlVmGetWord (ficlVm *vm);
+FICL_PLATFORM_EXTERN ficlString ficlVmGetWord0 (ficlVm *vm);
+FICL_PLATFORM_EXTERN int ficlVmGetWordToPad (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmInnerLoop (ficlVm *vm, ficlWord *word);
+FICL_PLATFORM_EXTERN ficlString ficlVmParseString (ficlVm *vm, char delimiter);
+FICL_PLATFORM_EXTERN ficlString ficlVmParseStringEx(ficlVm *vm, char delimiter, char fSkipLeading);
+FICL_PLATFORM_EXTERN ficlCell ficlVmPop (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmPush (ficlVm *vm, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlVmPopIP (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmPushIP (ficlVm *vm, ficlIp newIP);
+FICL_PLATFORM_EXTERN void ficlVmQuit (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmReset (ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmSetTextOut (ficlVm *vm, ficlOutputFunction textOut);
+FICL_PLATFORM_EXTERN void ficlVmThrow (ficlVm *vm, int except);
+FICL_PLATFORM_EXTERN void ficlVmThrowError (ficlVm *vm, char *fmt, ...);
+FICL_PLATFORM_EXTERN void ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list);
+FICL_PLATFORM_EXTERN void ficlVmTextOut (ficlVm *vm, char *text);
+FICL_PLATFORM_EXTERN void ficlVmErrorOut (ficlVm *vm, char *text);
+
+#define ficlVmGetContext(vm) ((vm)->context)
+#define ficlVmGetDataStack(vm) ((vm)->dataStack)
+#define ficlVmGetFloatStack(vm) ((vm)->floatStack)
+#define ficlVmGetReturnStack(vm) ((vm)->returnStack)
+#define ficlVmGetRunningWord(vm) ((vm)->runningWord)
+
+FICL_PLATFORM_EXTERN void ficlVmDisplayDataStack(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmDisplayDataStackSimple(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlVmDisplayReturnStack(ficlVm *vm);
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void ficlVmDisplayFloatStack(ficlVm *vm);
+#endif /* FICL_WANT_FLOAT */
+
+/*
+** 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.
+*/
+FICL_PLATFORM_EXTERN int ficlVmEvaluate(ficlVm *vm, char *s);
+
+/*
+** f i c l V m E x e c *
+** Evaluates a block of input text in the context of the
+** specified interpreter. Emits any requested output to the
+** interpreter's output function. If the input string is NULL
+** terminated, you can pass -1 as nChars rather than count it.
+** Execution returns when the text block has been executed,
+** or an error occurs.
+** Returns one of the FICL_VM_STATUS_... codes defined in ficl.h:
+** FICL_VM_STATUS_OUT_OF_TEXT is the normal exit condition
+** FICL_VM_STATUS_ERROR_EXIT means that the interpreter encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** FICL_VM_STATUS_USER_EXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
+** FICL_VM_STATUS_ABORT and FICL_VM_STATUS_ABORTQ are generated by 'abort' and 'abort"'
+** commands.
+** Preconditions: successful execution of ficlInitSystem,
+** Successful creation and init of the VM by ficlNewVM (or equivalent)
+**
+** If you call ficlExec() or one of its brothers, you MUST
+** ensure vm->sourceId was set to a sensible value.
+** ficlExec() explicitly DOES NOT manage SOURCE-ID for you.
+*/
+FICL_PLATFORM_EXTERN int ficlVmExecuteString(ficlVm *vm, ficlString s);
+FICL_PLATFORM_EXTERN int ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord);
+FICL_PLATFORM_EXTERN void ficlVmExecuteInstruction(ficlVm *vm, ficlInstruction i);
+FICL_PLATFORM_EXTERN void ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord);
+
+FICL_PLATFORM_EXTERN void ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n);
+FICL_PLATFORM_EXTERN void ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells);
+
+FICL_PLATFORM_EXTERN int ficlVmParseWord(ficlVm *vm, ficlString s);
+
+
+
+/*
+** TIB access routines...
+** ANS forth seems to require the input buffer to be represented
+** as a pointer to the start of the buffer, and an index to the
+** next character to read.
+** PushTib points the VM to a new input string and optionally
+** returns a copy of the current state
+** PopTib restores the TIB state given a saved TIB from PushTib
+** GetInBuf returns a pointer to the next unused char of the TIB
+*/
+FICL_PLATFORM_EXTERN void ficlVmPushTib (ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib);
+FICL_PLATFORM_EXTERN void ficlVmPopTib (ficlVm *vm, ficlTIB *pTib);
+#define ficlVmGetInBuf(vm) ((vm)->tib.text + (vm)->tib.index)
+#define ficlVmGetInBufLen(vm) ((vm)->tib.end - (vm)->tib.text)
+#define ficlVmGetInBufEnd(vm) ((vm)->tib.end)
+#define ficlVmGetTibIndex(vm) ((vm)->tib.index)
+#define ficlVmSetTibIndex(vm, i) ((vm)->tib.index = i)
+#define ficlVmUpdateTib(vm, str) ((vm)->tib.index = (str) - (vm)->tib.text)
+
+#if FICL_ROBUST >= 1
+ FICL_PLATFORM_EXTERN void ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int n);
+ FICL_PLATFORM_EXTERN void ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int n);
+ #define FICL_VM_DICTIONARY_CHECK(vm, dictionary, n) ficlVmDictionaryCheck(vm, dictionary, n)
+ #define FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n) ficlVmDictionarySimpleCheck(vm, dictionary, n)
+#else
+ #define FICL_VM_DICTIONARY_CHECK(vm, dictionary, n)
+ #define FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n)
+#endif /* FICL_ROBUST >= 1 */
+
+
+
+FICL_PLATFORM_EXTERN void ficlPrimitiveLiteralIm(ficlVm *vm);
+
+/*
+** A FICL_CODE points to a function that gets called to help execute
+** 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.
+*/
+
+
+/*
+** Ficl models memory as a contiguous space divided into
+** words in a linked list called the dictionary.
+** A ficlWord starts each entry in the list.
+** Version 1.02: space for the name characters is allotted from
+** the dictionary ahead of the word struct, rather than using
+** a fixed size array for each name.
+*/
+struct ficlWord
+{+ struct ficlWord *link; /* Previous word in the dictionary */
+ ficlUnsigned16 hash;
+ ficlUnsigned8 flags; /* Immediate, Smudge, Compile-only, IsOjbect, Instruction */
+ ficlUnsigned8 length; /* Number of chars in word name */
+ char *name; /* First nFICLNAME chars of word name */
+ ficlPrimitive code; /* Native code to execute the word */
+ ficlInstruction semiParen; /* Native code to execute the word */
+ ficlCell param[1]; /* First data cell of the word */
+};
+
+/*
+** ficlWord.flag bitfield values:
+*/
+
+/*
+** FICL_WORD_IMMEDIATE:
+** This word is always executed immediately when
+** encountered, even when compiling.
+*/
+#define FICL_WORD_IMMEDIATE ( 1)
+
+/*
+** FICL_WORD_COMPILE_ONLY:
+** This word is only valid during compilation.
+** Ficl will throw a runtime error if this word executed
+** while not compiling.
+*/
+#define FICL_WORD_COMPILE_ONLY ( 2)
+
+/*
+** FICL_WORD_SMUDGED
+** This word's definition is in progress.
+** The word is hidden from dictionary lookups
+** until it is "un-smudged".
+*/
+#define FICL_WORD_SMUDGED ( 4)
+
+/*
+** FICL_WORD_OBJECT
+** This word is an object or object member variable.
+** (Currently only used by "my=[".)
+*/
+#define FICL_WORD_OBJECT ( 8)
+
+/*
+** FICL_WORD_INSTRUCTION
+** This word represents a ficlInstruction, not a normal word.
+** param[0] is the instruction.
+** When compiled, Ficl will simply copy over the instruction,
+** rather than executing the word as normal.
+**
+** (Do *not* use this flag for words that need their PFA pushed
+** before executing!)
+*/
+#define FICL_WORD_INSTRUCTION (16)
+
+/*
+** FICL_WORD_COMPILE_ONLY_IMMEDIATE
+** Most words that are "immediate" are also
+** "compile-only".
+*/
+#define FICL_WORD_COMPILE_ONLY_IMMEDIATE (FICL_WORD_IMMEDIATE | FICL_WORD_COMPILE_ONLY)
+#define FICL_WORD_DEFAULT ( 0)
+
+
+/*
+** Worst-case size of a word header: FICL_NAME_LENGTH chars in name
+*/
+#define FICL_CELLS_PER_WORD \
+ ( (sizeof (ficlWord) + FICL_NAME_LENGTH + sizeof (ficlCell)) \
+ / (sizeof (ficlCell)) )
+
+FICL_PLATFORM_EXTERN int ficlWordIsImmediate(ficlWord *word);
+FICL_PLATFORM_EXTERN int ficlWordIsCompileOnly(ficlWord *word);
+
+
+
+
+#if FICL_ROBUST >= 1
+ FICL_PLATFORM_EXTERN void ficlCallbackAssert(ficlCallback *callback, int expression, char *expressionString, char *filename, int line);
+ #define FICL_ASSERT(callback, expression) (ficlCallbackAssert((callback), (expression) != 0, #expression, __FILE__, __LINE__))
+#else
+ #define FICL_ASSERT(callback, expression)
+#endif /* FICL_ROBUST >= 1 */
+
+#define FICL_VM_ASSERT(vm, expression) FICL_ASSERT((ficlCallback *)(vm), (expression))
+#define FICL_SYSTEM_ASSERT(system, expression) FICL_ASSERT((ficlCallback *)(system), (expression))
+
+
+
+/*
+** Generally useful string manipulators omitted by ANSI C...
+** ltoa complements strtol
+*/
+
+FICL_PLATFORM_EXTERN int ficlIsPowerOfTwo(ficlUnsigned u);
+
+FICL_PLATFORM_EXTERN char *ficlLtoa(ficlInteger value, char *string, int radix );
+FICL_PLATFORM_EXTERN char *ficlUltoa(ficlUnsigned value, char *string, int radix );
+FICL_PLATFORM_EXTERN char ficlDigitToCharacter(int value);
+FICL_PLATFORM_EXTERN char *ficlStringReverse( char *string );
+FICL_PLATFORM_EXTERN char *ficlStringSkipSpace(char *s, char *end);
+FICL_PLATFORM_EXTERN char *ficlStringCaseFold(char *s);
+FICL_PLATFORM_EXTERN int ficlStrincmp(char *s1, char *s2, ficlUnsigned length);
+FICL_PLATFORM_EXTERN void *ficlAlignPointer(void *ptr);
+
+
+/*
+** 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.
+*/
+
+typedef struct ficlHash
+{+ struct ficlHash *link; /* link to parent class wordlist for OO */
+ char *name; /* optional pointer to \0 terminated wordlist name */
+ unsigned size; /* number of buckets in the hash */
+ ficlWord *table[1];
+} ficlHash;
+
+FICL_PLATFORM_EXTERN void ficlHashForget (ficlHash *hash, void *where);
+FICL_PLATFORM_EXTERN ficlUnsigned16 ficlHashCode (ficlString s);
+FICL_PLATFORM_EXTERN void ficlHashInsertWord(ficlHash *hash, ficlWord *word);
+FICL_PLATFORM_EXTERN ficlWord *ficlHashLookup (ficlHash *hash, ficlString name, ficlUnsigned16 hashCode);
+FICL_PLATFORM_EXTERN void ficlHashReset (ficlHash *hash);
+
+/*
+** A Dictionary is a linked list of FICL_WORDs. It is also Ficl's
+** 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.
+**
+** forthWordlist -- pointer to the default wordlist (FICL_HASH).
+** This is the initial compilation list, and contains all
+** Ficl's precompiled words.
+**
+** compilationWordlist -- compilation wordlist - initially equal to forthWordlist
+** wordlists -- array of pointers to wordlists. Managed as a stack.
+** Highest index is the first list in the search order.
+** wordlistCount -- number of lists in wordlists. wordlistCount-1 is the highest
+** filled slot in wordlists, and points to the first wordlist
+** in the search order
+** size -- number of cells in the dictionary (total)
+** base -- start of data area. Must be at the end of the struct.
+*/
+struct ficlDictionary
+{+ ficlCell *here;
+ void *context; /* for your use, particularly with ficlDictionaryLock() */
+ ficlWord *smudge;
+ ficlHash *forthWordlist;
+ ficlHash *compilationWordlist;
+ ficlHash *wordlists[FICL_MAX_WORDLISTS];
+ int wordlistCount;
+ unsigned size; /* Number of cells in dictionary (total)*/
+ ficlSystem *system; /* used for debugging */
+ ficlCell base[1]; /* Base of dictionary memory */
+};
+
+FICL_PLATFORM_EXTERN void ficlDictionaryAbortDefinition(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryAlign (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryAllot (ficlDictionary *dictionary, int n);
+FICL_PLATFORM_EXTERN void ficlDictionaryAllotCells (ficlDictionary *dictionary, int nCells);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendCell (ficlDictionary *dictionary, ficlCell c);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendCharacter(ficlDictionary *dictionary, char c);
+FICL_PLATFORM_EXTERN void ficlDictionaryAppendUnsigned(ficlDictionary *dictionary, ficlUnsigned u);
+FICL_PLATFORM_EXTERN void *ficlDictionaryAppendData(ficlDictionary *dictionary, void *data, ficlInteger length);
+FICL_PLATFORM_EXTERN char *ficlDictionaryAppendString(ficlDictionary *dictionary, ficlString s);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendWord(ficlDictionary *dictionary,
+ ficlString name,
+ ficlPrimitive pCode,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendPrimitive(ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive pCode,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppend2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendConstant(ficlDictionary *dictionary, char *name, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppend2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value);
+#define ficlDictionaryAppendConstantPointer(dictionary, name, pointer) \
+ (ficlDictionaryAppendConstant(dictionary, name, (ficlInteger)pointer))
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name, float value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name, double value);
+#endif /* FICL_WANT_FLOAT */
+
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySet2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value);
+
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstant(ficlDictionary *dictionary, char *name, ficlInteger value);
+#define ficlDictionarySetConstantPointer(dictionary, name, pointer) \
+ (ficlDictionarySetConstant(dictionary, name, (ficlInteger)pointer))
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySet2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetConstantString(ficlDictionary *dictionary, char *name, char *value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary,
+ char *name,
+ ficlPrimitive code,
+ ficlUnsigned8 flags);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetInstruction(ficlDictionary *dictionary,
+ char *name,
+ ficlInstruction i,
+ ficlUnsigned8 flags);
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name, float value);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name, double value);
+#endif /* FICL_WANT_FLOAT */
+
+FICL_PLATFORM_EXTERN int ficlDictionaryCellsAvailable (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN int ficlDictionaryCellsUsed (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlDictionaryCreate(ficlSystem *system, unsigned nCELLS);
+FICL_PLATFORM_EXTERN ficlDictionary *ficlDictionaryCreateHashed(ficlSystem *system, unsigned nCells, unsigned nHash);
+FICL_PLATFORM_EXTERN ficlHash *ficlDictionaryCreateWordlist(ficlDictionary *dictionary, int nBuckets);
+FICL_PLATFORM_EXTERN void ficlDictionaryDestroy (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryEmpty (ficlDictionary *dictionary, unsigned nHash);
+FICL_PLATFORM_EXTERN int ficlDictionaryIncludes (ficlDictionary *dictionary, void *p);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryLookup (ficlDictionary *dictionary, ficlString name);
+FICL_PLATFORM_EXTERN void ficlDictionaryResetSearchOrder(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionarySetFlags (ficlDictionary *dictionary, ficlUnsigned8 set);
+FICL_PLATFORM_EXTERN void ficlDictionaryClearFlags(ficlDictionary *dictionary, ficlUnsigned8 clear);
+FICL_PLATFORM_EXTERN void ficlDictionarySetImmediate(ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN void ficlDictionaryUnsmudge (ficlDictionary *dictionary);
+FICL_PLATFORM_EXTERN ficlCell *ficlDictionaryWhere (ficlDictionary *dictionary);
+
+FICL_PLATFORM_EXTERN int ficlDictionaryIsAWord(ficlDictionary *dictionary, ficlWord *word);
+FICL_PLATFORM_EXTERN void ficlDictionarySee(ficlDictionary *dictionary, ficlWord *word, ficlCallback *callback);
+FICL_PLATFORM_EXTERN ficlWord *ficlDictionaryFindEnclosingWord(ficlDictionary *dictionary, ficlCell *cell);
+
+/*
+** Stub function for dictionary access control - does nothing
+** by default, user can redefine to guarantee exclusive dictionary
+** access to a single thread for updates. All dictionary update code
+** must be bracketed as follows:
+** ficlLockDictionary(dictionary, FICL_TRUE); // any non-zero value will do
+** <code that updates dictionary>
+** ficlLockDictionary(dictionary, FICL_FALSE);
+**
+** Returns zero if successful, nonzero if unable to acquire lock
+** before timeout (optional - could also block forever)
+**
+** NOTE: this function must be implemented with lock counting
+** semantics: nested calls must behave properly.
+*/
+#if FICL_MULTITHREAD
+FICL_PLATFORM_EXTERN int ficlDictionaryLock(ficlDictionary *dictionary, short lockIncrement);
+#else
+#define ficlDictionaryLock(dictionary, lock) 0 /* ignore */
+#endif
+
+
+
+/*
+** 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 (*ficlParseStep)(ficlVm *vm, ficlString s);
+
+/*
+** FICL_BREAKPOINT record.
+** oldXT - if NULL, this breakpoint is unused. Otherwise it stores the xt
+** that the breakpoint overwrote. This is restored to the dictionary when the
+** BP executes or gets cleared
+** address - the location of the breakpoint (address of the instruction that
+** has been replaced with the breakpoint trap
+** oldXT - The original contents of the location with the breakpoint
+** Note: address is NULL when this breakpoint is empty
+*/
+typedef struct ficlBreakpoint
+{+ void *address;
+ ficlWord *oldXT;
+} ficlBreakpoint;
+
+
+/*
+** F I C L _ S Y S T E M
+** The top level data structure of the system - ficl_system ties a list of
+** virtual machines with their corresponding dictionaries. Ficl 3.0 added
+** support for multiple Ficl systems, allowing multiple concurrent sessions
+** to separate dictionaries with some constraints.
+** Note: the context pointer is there to provide context for applications. It is copied
+** to each VM's context field as that VM is created.
+*/
+struct ficlSystemInformation
+{+ int size; /* structure size tag for versioning */
+ void *context; /* Initializes VM's context pointer - for application use */
+ int dictionarySize; /* Size of system's Dictionary, in cells */
+ int stackSize; /* Size of all stacks created, in cells */
+ ficlOutputFunction textOut; /* default textOut function */
+ ficlOutputFunction errorOut; /* textOut function used for errors */
+ int environmentSize; /* Size of Environment dictionary, in cells */
+};
+
+#define ficlSystemInformationInitialize(x) { memset((x), 0, sizeof(ficlSystemInformation)); \+ (x)->size = sizeof(ficlSystemInformation); }
+
+
+
+
+struct ficlSystem
+{+ ficlCallback callback;
+ ficlSystem *link;
+ ficlVm *vmList;
+ ficlDictionary *dictionary;
+ ficlDictionary *environment;
+
+ ficlWord *interpreterLoop[3];
+ ficlWord *parseList[FICL_MAX_PARSE_STEPS];
+
+ ficlWord *exitInnerWord;
+ ficlWord *interpretWord;
+
+#if FICL_WANT_LOCALS
+ ficlDictionary *locals;
+ ficlInteger localsCount;
+ ficlCell *localsFixup;
+#endif
+
+ ficlInteger stackSize;
+
+ ficlBreakpoint breakpoint;
+#if FICL_WANT_COMPATIBILITY
+ ficlCompatibilityOutputFunction thunkedTextout;
+#endif /* FICL_WANT_COMPATIBILITY */
+};
+
+
+#define ficlSystemGetContext(system) ((system)->context)
+
+
+/*
+** External interface to Ficl...
+*/
+/*
+** f i c l S y s t e m C r e a t e
+** Binds a global dictionary to the interpreter system and initializes
+** the dictionary to contain the ANSI CORE wordset.
+** You can specify the address and size of the allocated area.
+** You can also specify the text output function at creation time.
+** After that, Ficl manages it.
+** First step is to set up the static pointers to the area.
+** Then write the "precompiled" portion of the dictionary in.
+** The dictionary needs to be at least large enough to hold the
+** precompiled part. Try 1K cells minimum. Use "words" to find
+** out how much of the dictionary is used at any time.
+*/
+FICL_PLATFORM_EXTERN ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi);
+
+/*
+** f i c l S y s t e m D e s t r o y
+** Deletes the system dictionary and all virtual machines that
+** were created with ficlNewVM (see below). Call this function to
+** reclaim all memory used by the dictionary and VMs.
+*/
+FICL_PLATFORM_EXTERN void ficlSystemDestroy(ficlSystem *system);
+
+/*
+** 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_PLATFORM_EXTERN ficlVm *ficlSystemCreateVm(ficlSystem *system);
+
+/*
+** 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.
+*/
+FICL_PLATFORM_EXTERN void ficlSystemDestroyVm(ficlVm *vm);
+
+
+/*
+** 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_PLATFORM_EXTERN ficlWord *ficlSystemLookup(ficlSystem *system, char *name);
+
+/*
+** f i c l G e t D i c t
+** Utility function - returns the address of the system dictionary.
+** Precondition: successful execution of ficlInitSystem
+*/
+ficlDictionary *ficlSystemGetDictionary(ficlSystem *system);
+ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system);
+#if FICL_WANT_LOCALS
+ficlDictionary *ficlSystemGetLocals(ficlSystem *system);
+#endif
+
+/*
+** 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 dictionary space by doing it again.
+*/
+FICL_PLATFORM_EXTERN void ficlSystemCompileCore(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompilePrefix(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileSearch(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileSoftCore(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileTools(ficlSystem *system);
+FICL_PLATFORM_EXTERN void ficlSystemCompileFile(ficlSystem *system);
+#if FICL_WANT_FLOAT
+FICL_PLATFORM_EXTERN void ficlSystemCompileFloat(ficlSystem *system);
+FICL_PLATFORM_EXTERN int ficlVmParseFloatNumber(ficlVm *vm, ficlString s);
+#endif /* FICL_WANT_FLOAT */
+#if FICL_WANT_PLATFORM
+FICL_PLATFORM_EXTERN void ficlSystemCompilePlatform(ficlSystem *system);
+#endif /* FICL_WANT_PLATFORM */
+FICL_PLATFORM_EXTERN void ficlSystemCompileExtras(ficlSystem *system);
+
+
+FICL_PLATFORM_EXTERN int ficlVmParsePrefix(ficlVm *vm, ficlString s);
+
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN ficlWord *ficlSystemLookupLocal(ficlSystem *system, ficlString name);
+#endif
+
+/*
+** from words.c...
+*/
+FICL_PLATFORM_EXTERN int ficlVmParseNumber(ficlVm *vm, ficlString s);
+FICL_PLATFORM_EXTERN void ficlPrimitiveTick(ficlVm *vm);
+FICL_PLATFORM_EXTERN void ficlPrimitiveParseStepParen(ficlVm *vm);
+#if FICL_WANT_LOCALS
+FICL_PLATFORM_EXTERN void ficlLocalParen(ficlVm *vm, int isDouble, int isFloat);
+#endif /* FICL_WANT_LOCALS */
+
+
+/*
+** Appends a parse step function to the end of the parse list (see
+** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
+** nonzero if there's no more room in the list. Each parse step is a word in
+** the dictionary. Precompiled parse steps can use (PARSE-STEP) as their
+** CFA - see parenParseStep in words.c.
+*/
+FICL_PLATFORM_EXTERN int ficlSystemAddParseStep(ficlSystem *system, ficlWord *word); /* ficl.c */
+FICL_PLATFORM_EXTERN void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep pStep);
+
+
+/*
+** From tools.c
+*/
+
+/*
+** The following supports SEE and the debugger.
+*/
+typedef enum
+{+ FICL_WORDKIND_BRANCH,
+ FICL_WORDKIND_BRANCH0,
+ FICL_WORDKIND_COLON,
+ FICL_WORDKIND_CONSTANT,
+ FICL_WORDKIND_2CONSTANT,
+ FICL_WORDKIND_CREATE,
+ FICL_WORDKIND_DO,
+ FICL_WORDKIND_DOES,
+ FICL_WORDKIND_LITERAL,
+ FICL_WORDKIND_2LITERAL,
+#if FICL_WANT_FLOAT
+ FICL_WORDKIND_FLITERAL,
+#endif /* FICL_WANT_FLOAT */
+ FICL_WORDKIND_LOOP,
+ FICL_WORDKIND_OF,
+ FICL_WORDKIND_PLOOP,
+ FICL_WORDKIND_PRIMITIVE,
+ FICL_WORDKIND_QDO,
+ FICL_WORDKIND_STRING_LITERAL,
+ FICL_WORDKIND_CSTRING_LITERAL,
+#if FICL_WANT_USER
+ FICL_WORDKIND_USER,
+#endif
+ FICL_WORDKIND_VARIABLE,
+ FICL_WORDKIND_INSTRUCTION,
+ FICL_WORDKIND_INSTRUCTION_WORD,
+ FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT,
+} ficlWordKind;
+
+ficlWordKind ficlWordClassify(ficlWord *word);
+
+
+
+
+/*
+** Used with File-Access wordset.
+*/
+#define FICL_FAM_READ 1
+#define FICL_FAM_WRITE 2
+#define FICL_FAM_APPEND 4
+#define FICL_FAM_BINARY 8
+
+#define FICL_FAM_OPEN_MODE(fam) ((fam) & (FICL_FAM_READ | FICL_FAM_WRITE | FICL_FAM_APPEND))
+
+
+typedef struct ficlFile
+{+ FILE *f;
+ char filename[256];
+} ficlFile;
+
+
+#if defined (FICL_PLATFORM_HAS_FTRUNCATE)
+FICL_PLATFORM_EXTERN int ficlFileTruncate(ficlFile *ff, ficlUnsigned size);
+#endif
+
+FICL_PLATFORM_EXTERN int ficlFileStatus(char *filename, int *status);
+FICL_PLATFORM_EXTERN long ficlFileSize(ficlFile *ff);
+
+
+/*
+** Used with compressed softcore.
+**
+*/
+
+#ifndef FICL_BIT_NUMBER
+#define FICL_BIT_NUMBER(x) (1 << (x))
+#endif /* FICL_BIT_NUMBER */
+
+#ifndef FICL_BIT_SET
+#define FICL_BIT_SET(value, flag) ((value) |= (flag))
+#endif /* FICL_BIT_SET */
+
+#ifndef FICL_BIT_CLEAR
+#define FICL_BIT_CLEAR(value, flag) ((value) &= ~(flag))
+#endif /* FICL_BIT_CLEAR */
+
+#ifndef FICL_BIT_CHECK
+#define FICL_BIT_CHECK(value, flag) ((value) & (flag))
+#endif /* FICL_BIT_CHECK */
+
+
+#define FICL_LZ_TYPE_BITS (1)
+#define FICL_LZ_OFFSET_BITS (12)
+#define FICL_LZ_LENGTH_BITS (5)
+#define FICL_LZ_NEXT_BITS (8)
+#define FICL_LZ_PHRASE_BITS (FICL_LZ_TYPE_BITS + FICL_LZ_OFFSET_BITS + FICL_LZ_LENGTH_BITS + FICL_LZ_NEXT_BITS)
+#define FICL_LZ_SYMBOL_BITS (FICL_LZ_TYPE_BITS + FICL_LZ_NEXT_BITS)
+
+/*
+** if you match fewer characters than this, don't bother,
+** it's smaller to encode it as a sequence of symbol tokens.
+**/
+#define FICL_LZ_MINIMUM_USEFUL_MATCH ((int)(FICL_LZ_PHRASE_BITS / FICL_LZ_SYMBOL_BITS))
+
+#define FICL_LZ_WINDOW_SIZE (FICL_BIT_NUMBER(FICL_LZ_OFFSET_BITS))
+#define FICL_LZ_BUFFER_SIZE (FICL_BIT_NUMBER(FICL_LZ_LENGTH_BITS) + FICL_LZ_MINIMUM_USEFUL_MATCH)
+
+FICL_PLATFORM_EXTERN int ficlBitGet(const unsigned char *bits, size_t index);
+FICL_PLATFORM_EXTERN void ficlBitSet(unsigned char *bits, size_t size_t, int value);
+FICL_PLATFORM_EXTERN void ficlBitGetString(unsigned char *destination, const unsigned char *source, int offset, int count, int destAlignment);
+
+FICL_PLATFORM_EXTERN ficlUnsigned16 ficlNetworkUnsigned16(ficlUnsigned16 number);
+FICL_PLATFORM_EXTERN ficlUnsigned32 ficlNetworkUnsigned32(ficlUnsigned32 number);
+
+#define FICL_MIN(a, b) (((a) < (b)) ? (a) : (b))
+FICL_PLATFORM_EXTERN int ficlLzCompress(const unsigned char *uncompressed, size_t uncompressedSize, unsigned char **compressed, size_t *compressedSize);
+FICL_PLATFORM_EXTERN int ficlLzUncompress(const unsigned char *compressed, unsigned char **uncompressed, size_t *uncompressedSize);
+
+
+
+#if FICL_WANT_COMPATIBILITY
+ #include "ficlcompatibility.h"
+#endif /* FICL_WANT_COMPATIBILITY */
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __FICL_H__ */
--- a/fileaccess.c
+++ b/fileaccess.c
@@ -1,423 +1,387 @@
-#include <errno.h>
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <ctype.h>
-#include <sys/stat.h>
-#include "ficl.h"
-
-#if FICL_WANT_FILE
-/*
-**
-** fileaccess.c
-**
-** Implements all of the File Access word set that can be implemented in portable C.
-**
-*/
-
-static void pushIor(FICL_VM *pVM, int success)
-{
- int ior;
- if (success)
- ior = 0;
- else
- ior = errno;
- stackPushINT(pVM->pStack, ior);
-}
-
-
-
-static void ficlFopen(FICL_VM *pVM, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
-{
- int fam = stackPopINT(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
- char mode[4];
- FILE *f;
-
- char *filename = (char *)alloca(length + 1);
- memcpy(filename, address, length);
- filename[length] = 0;
-
- *mode = 0;
-
- switch (FICL_FAM_OPEN_MODE(fam))
- {
- case 0:
- stackPushPtr(pVM->pStack, NULL);
- stackPushINT(pVM->pStack, EINVAL);
- return;
- case FICL_FAM_READ:
- strcat(mode, "r");
- break;
- case FICL_FAM_WRITE:
- strcat(mode, writeMode);
- break;
- case FICL_FAM_READ | FICL_FAM_WRITE:
- strcat(mode, writeMode);
- strcat(mode, "+");
- break;
- }
-
- strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t");
-
- f = fopen(filename, mode);
- if (f == NULL)
- stackPushPtr(pVM->pStack, NULL);
- else
- {
- ficlFILE *ff = (ficlFILE *)malloc(sizeof(ficlFILE));
- strcpy(ff->filename, filename);
- ff->f = f;
- stackPushPtr(pVM->pStack, ff);
-
- fseek(f, 0, SEEK_SET);
- }
- pushIor(pVM, f != NULL);
-}
-
-
-
-static void ficlOpenFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
-{
- ficlFopen(pVM, "a");
-}
-
-
-static void ficlCreateFile(FICL_VM *pVM) /* ( c-addr u fam -- fileid ior ) */
-{
- ficlFopen(pVM, "w");
-}
-
-
-static int closeFiclFILE(ficlFILE *ff) /* ( fileid -- ior ) */
-{
- FILE *f = ff->f;
- free(ff);
- return !fclose(f);
-}
-
-static void ficlCloseFile(FICL_VM *pVM) /* ( fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- pushIor(pVM, closeFiclFILE(ff));
-}
-
-static void ficlDeleteFile(FICL_VM *pVM) /* ( c-addr u -- ior ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *filename = (char *)alloca(length + 1);
- memcpy(filename, address, length);
- filename[length] = 0;
-
- pushIor(pVM, !unlink(filename));
-}
-
-static void ficlRenameFile(FICL_VM *pVM) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
-{
- int length;
- void *address;
- char *from;
- char *to;
-
- length = stackPopINT(pVM->pStack);
- address = (void *)stackPopPtr(pVM->pStack);
- to = (char *)alloca(length + 1);
- memcpy(to, address, length);
- to[length] = 0;
-
- length = stackPopINT(pVM->pStack);
- address = (void *)stackPopPtr(pVM->pStack);
-
- from = (char *)alloca(length + 1);
- memcpy(from, address, length);
- from[length] = 0;
-
- pushIor(pVM, !rename(from, to));
-}
-
-static void ficlFileStatus(FICL_VM *pVM) /* ( c-addr u -- x ior ) */
-{
- struct stat statbuf;
-
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *filename = (char *)alloca(length + 1);
- memcpy(filename, address, length);
- filename[length] = 0;
-
- if (stat(filename, &statbuf) == 0)
- {
- /*
- ** the "x" left on the stack is implementation-defined.
- ** I push the file's access mode (readable, writeable, is directory, etc)
- ** as defined by ANSI C.
- */
- stackPushINT(pVM->pStack, statbuf.st_mode);
- stackPushINT(pVM->pStack, 0);
- }
- else
- {
- stackPushINT(pVM->pStack, -1);
- stackPushINT(pVM->pStack, ENOENT);
- }
-}
-
-
-static void ficlFilePosition(FICL_VM *pVM) /* ( fileid -- ud ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- long ud = ftell(ff->f);
- stackPushINT(pVM->pStack, ud);
- pushIor(pVM, ud != -1);
-}
-
-
-
-static long fileSize(FILE *f)
-{
- struct stat statbuf;
- statbuf.st_size = -1;
- if (fstat(fileno(f), &statbuf) != 0)
- return -1;
- return statbuf.st_size;
-}
-
-
-
-static void ficlFileSize(FICL_VM *pVM) /* ( fileid -- ud ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- long ud = fileSize(ff->f);
- stackPushINT(pVM->pStack, ud);
- pushIor(pVM, ud != -1);
-}
-
-
-
-#define nLINEBUF 256
-static void ficlIncludeFile(FICL_VM *pVM) /* ( i*x fileid -- j*x ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- CELL id = pVM->sourceID;
- int result = VM_OUTOFTEXT;
- long currentPosition, totalSize;
- long size;
- pVM->sourceID.p = (void *)ff;
-
- currentPosition = ftell(ff->f);
- totalSize = fileSize(ff->f);
- size = totalSize - currentPosition;
-
- if ((totalSize != -1) && (currentPosition != -1) && (size > 0))
- {
- char *buffer = (char *)malloc(size);
- long got = fread(buffer, 1, size, ff->f);
- if (got == size)
- result = ficlExecC(pVM, buffer, size);
- }
-
-#if 0
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- CELL id = pVM->sourceID;
- char cp[nLINEBUF];
- int nLine = 0;
- int keepGoing;
- int result;
- pVM->sourceID.p = (void *)ff;
-
- /* feed each line to ficlExec */
- keepGoing = TRUE;
- while (keepGoing && fgets(cp, nLINEBUF, ff->f))
- {
- int len = strlen(cp) - 1;
-
- nLine++;
- if (len <= 0)
- continue;
-
- if (cp[len] == '\n')
- cp[len] = '\0';
-
- result = ficlExec(pVM, cp);
-
- switch (result)
- {
- case VM_OUTOFTEXT:
- case VM_USEREXIT:
- break;
-
- default:
- pVM->sourceID = id;
- keepGoing = FALSE;
- break;
- }
- }
-#endif /* 0 */
- /*
- ** Pass an empty line with SOURCE-ID == -1 to flush
- ** any pending REFILLs (as required by FILE wordset)
- */
- pVM->sourceID.i = -1;
- ficlExec(pVM, "");
-
- pVM->sourceID = id;
- closeFiclFILE(ff);
-}
-
-
-
-static void ficlReadFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
- int result;
-
- clearerr(ff->f);
- result = fread(address, 1, length, ff->f);
-
- stackPushINT(pVM->pStack, result);
- pushIor(pVM, ferror(ff->f) == 0);
-}
-
-
-
-static void ficlReadLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- u2 flag ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- char *address = (char *)stackPopPtr(pVM->pStack);
- int error;
- int flag;
-
- if (feof(ff->f))
- {
- stackPushINT(pVM->pStack, -1);
- stackPushINT(pVM->pStack, 0);
- stackPushINT(pVM->pStack, 0);
- return;
- }
-
- clearerr(ff->f);
- *address = 0;
- fgets(address, length, ff->f);
-
- error = ferror(ff->f);
- if (error != 0)
- {
- stackPushINT(pVM->pStack, -1);
- stackPushINT(pVM->pStack, 0);
- stackPushINT(pVM->pStack, error);
- return;
- }
-
- length = strlen(address);
- flag = (length > 0);
- if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
- length--;
-
- stackPushINT(pVM->pStack, length);
- stackPushINT(pVM->pStack, flag);
- stackPushINT(pVM->pStack, 0); /* ior */
-}
-
-
-
-static void ficlWriteFile(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- clearerr(ff->f);
- fwrite(address, 1, length, ff->f);
- pushIor(pVM, ferror(ff->f) == 0);
-}
-
-
-
-static void ficlWriteLine(FICL_VM *pVM) /* ( c-addr u1 fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- size_t length = (size_t)stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- clearerr(ff->f);
- if (fwrite(address, 1, length, ff->f) == length)
- fwrite("\n", 1, 1, ff->f);
- pushIor(pVM, ferror(ff->f) == 0);
-}
-
-
-
-static void ficlRepositionFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- size_t ud = (size_t)stackPopINT(pVM->pStack);
-
- pushIor(pVM, fseek(ff->f, ud, SEEK_SET) == 0);
-}
-
-
-
-static void ficlFlushFile(FICL_VM *pVM) /* ( fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- pushIor(pVM, fflush(ff->f) == 0);
-}
-
-
-
-#if FICL_HAVE_FTRUNCATE
-
-static void ficlResizeFile(FICL_VM *pVM) /* ( ud fileid -- ior ) */
-{
- ficlFILE *ff = (ficlFILE *)stackPopPtr(pVM->pStack);
- size_t ud = (size_t)stackPopINT(pVM->pStack);
-
- pushIor(pVM, ftruncate(fileno(ff->f), ud) == 0);
-}
-
-#endif /* FICL_HAVE_FTRUNCATE */
-
-#endif /* FICL_WANT_FILE */
-
-
-
-void ficlCompileFile(FICL_SYSTEM *pSys)
-{
-#if FICL_WANT_FILE
- FICL_DICT *dp = pSys->dp;
- assert(dp);
-
- dictAppendWord(dp, "create-file", ficlCreateFile, FW_DEFAULT);
- dictAppendWord(dp, "open-file", ficlOpenFile, FW_DEFAULT);
- dictAppendWord(dp, "close-file", ficlCloseFile, FW_DEFAULT);
- dictAppendWord(dp, "include-file", ficlIncludeFile, FW_DEFAULT);
- dictAppendWord(dp, "read-file", ficlReadFile, FW_DEFAULT);
- dictAppendWord(dp, "read-line", ficlReadLine, FW_DEFAULT);
- dictAppendWord(dp, "write-file", ficlWriteFile, FW_DEFAULT);
- dictAppendWord(dp, "write-line", ficlWriteLine, FW_DEFAULT);
- dictAppendWord(dp, "file-position", ficlFilePosition, FW_DEFAULT);
- dictAppendWord(dp, "file-size", ficlFileSize, FW_DEFAULT);
- dictAppendWord(dp, "reposition-file", ficlRepositionFile, FW_DEFAULT);
- dictAppendWord(dp, "file-status", ficlFileStatus, FW_DEFAULT);
- dictAppendWord(dp, "flush-file", ficlFlushFile, FW_DEFAULT);
-
- dictAppendWord(dp, "delete-file", ficlDeleteFile, FW_DEFAULT);
- dictAppendWord(dp, "rename-file", ficlRenameFile, FW_DEFAULT);
-
-#ifdef FICL_HAVE_FTRUNCATE
- dictAppendWord(dp, "resize-file", ficlResizeFile, FW_DEFAULT);
-
- ficlSetEnv(pSys, "file", FICL_TRUE);
- ficlSetEnv(pSys, "file-ext", FICL_TRUE);
-#endif /* FICL_HAVE_FTRUNCATE */
-#else
- &pSys;
-#endif /* FICL_WANT_FILE */
-}
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.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(ficlVm *vm, int success)
+{+ int ior;
+ if (success)
+ ior = 0;
+ else
+ ior = errno;
+ ficlStackPushInteger(vm->dataStack, ior);
+}
+
+
+
+static void ficlFileOpen(ficlVm *vm, char *writeMode) /* ( c-addr u fam -- fileid ior ) */
+{+ int fam = ficlStackPopInteger(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+ char mode[4];
+ FILE *f;
+ char *filename = (char *)malloc(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ *mode = 0;
+
+ switch (FICL_FAM_OPEN_MODE(fam))
+ {+ case 0:
+ ficlStackPushPointer(vm->dataStack, NULL);
+ ficlStackPushInteger(vm->dataStack, EINVAL);
+ goto EXIT;
+ 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)
+ ficlStackPushPointer(vm->dataStack, NULL);
+ else
+ {+ ficlFile *ff = (ficlFile *)malloc(sizeof(ficlFile));
+ strcpy(ff->filename, filename);
+ ff->f = f;
+ ficlStackPushPointer(vm->dataStack, ff);
+
+ fseek(f, 0, SEEK_SET);
+ }
+ pushIor(vm, f != NULL);
+
+EXIT:
+ free(filename);
+}
+
+
+
+static void ficlPrimitiveOpenFile(ficlVm *vm) /* ( c-addr u fam -- fileid ior ) */
+{+ ficlFileOpen(vm, "a");
+}
+
+
+static void ficlPrimitiveCreateFile(ficlVm *vm) /* ( c-addr u fam -- fileid ior ) */
+{+ ficlFileOpen(vm, "w");
+}
+
+
+static int ficlFileClose(ficlFile *ff) /* ( fileid -- ior ) */
+{+ FILE *f = ff->f;
+ free(ff);
+ return !fclose(f);
+}
+
+static void ficlPrimitiveCloseFile(ficlVm *vm) /* ( fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ pushIor(vm, ficlFileClose(ff));
+}
+
+static void ficlPrimitiveDeleteFile(ficlVm *vm) /* ( c-addr u -- ior ) */
+{+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+
+ char *filename = (char *)malloc(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ pushIor(vm, !unlink(filename));
+ free(filename);
+}
+
+static void ficlPrimitiveRenameFile(ficlVm *vm) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */
+{+ int length;
+ void *address;
+ char *from;
+ char *to;
+
+ length = ficlStackPopInteger(vm->dataStack);
+ address = (void *)ficlStackPopPointer(vm->dataStack);
+ to = (char *)malloc(length + 1);
+ memcpy(to, address, length);
+ to[length] = 0;
+
+ length = ficlStackPopInteger(vm->dataStack);
+ address = (void *)ficlStackPopPointer(vm->dataStack);
+
+ from = (char *)malloc(length + 1);
+ memcpy(from, address, length);
+ from[length] = 0;
+
+ pushIor(vm, !rename(from, to));
+
+ free(from);
+ free(to);
+}
+
+static void ficlPrimitiveFileStatus(ficlVm *vm) /* ( c-addr u -- x ior ) */
+{+ int status;
+ int ior;
+
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+
+ char *filename = (char *)malloc(length + 1);
+ memcpy(filename, address, length);
+ filename[length] = 0;
+
+ ior = ficlFileStatus(filename, &status);
+ free(filename);
+
+ ficlStackPushInteger(vm->dataStack, status);
+ ficlStackPushInteger(vm->dataStack, ior);
+}
+
+
+static void ficlPrimitiveFilePosition(ficlVm *vm) /* ( fileid -- ud ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ long ud = ftell(ff->f);
+ ficlStackPushInteger(vm->dataStack, ud);
+ pushIor(vm, ud != -1);
+}
+
+
+
+static void ficlPrimitiveFileSize(ficlVm *vm) /* ( fileid -- ud ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ long ud = ficlFileSize(ff);
+ ficlStackPushInteger(vm->dataStack, ud);
+ pushIor(vm, ud != -1);
+}
+
+
+
+#define nLINEBUF 256
+static void ficlPrimitiveIncludeFile(ficlVm *vm) /* ( i*x fileid -- j*x ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ ficlCell id = vm->sourceId;
+ int except = FICL_VM_STATUS_OUT_OF_TEXT;
+ long currentPosition, totalSize;
+ long size;
+ ficlString s;
+ vm->sourceId.p = (void *)ff;
+
+ currentPosition = ftell(ff->f);
+ totalSize = ficlFileSize(ff);
+ size = totalSize - currentPosition;
+
+ if ((totalSize != -1) && (currentPosition != -1) && (size > 0))
+ {+ char *buffer = (char *)malloc(size);
+ long got = fread(buffer, 1, size, ff->f);
+ if (got == size)
+ {+ FICL_STRING_SET_POINTER(s, buffer);
+ FICL_STRING_SET_LENGTH(s, size);
+ except = ficlVmExecuteString(vm, s);
+ }
+ }
+
+ if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT))
+ ficlVmThrow(vm, except);
+
+ /*
+ ** Pass an empty line with SOURCE-ID == -1 to flush
+ ** any pending REFILLs (as required by FILE wordset)
+ */
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_FROM_CSTRING(s, "");
+ ficlVmExecuteString(vm, s);
+
+ vm->sourceId = id;
+ ficlFileClose(ff);
+}
+
+
+
+static void ficlPrimitiveReadFile(ficlVm *vm) /* ( c-addr u1 fileid -- u2 ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+ int result;
+
+ clearerr(ff->f);
+ result = fread(address, 1, length, ff->f);
+
+ ficlStackPushInteger(vm->dataStack, result);
+ pushIor(vm, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlPrimitiveReadLine(ficlVm *vm) /* ( c-addr u1 fileid -- u2 flag ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ char *address = (char *)ficlStackPopPointer(vm->dataStack);
+ int error;
+ int flag;
+
+ if (feof(ff->f))
+ {+ ficlStackPushInteger(vm->dataStack, -1);
+ ficlStackPushInteger(vm->dataStack, 0);
+ ficlStackPushInteger(vm->dataStack, 0);
+ return;
+ }
+
+ clearerr(ff->f);
+ *address = 0;
+ fgets(address, length, ff->f);
+
+ error = ferror(ff->f);
+ if (error != 0)
+ {+ ficlStackPushInteger(vm->dataStack, -1);
+ ficlStackPushInteger(vm->dataStack, 0);
+ ficlStackPushInteger(vm->dataStack, error);
+ return;
+ }
+
+ length = strlen(address);
+ flag = (length > 0);
+ if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n')))
+ length--;
+
+ ficlStackPushInteger(vm->dataStack, length);
+ ficlStackPushInteger(vm->dataStack, flag);
+ ficlStackPushInteger(vm->dataStack, 0); /* ior */
+}
+
+
+
+static void ficlPrimitiveWriteFile(ficlVm *vm) /* ( c-addr u1 fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ int length = ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+
+ clearerr(ff->f);
+ fwrite(address, 1, length, ff->f);
+ pushIor(vm, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlPrimitiveWriteLine(ficlVm *vm) /* ( c-addr u1 fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t length = (size_t)ficlStackPopInteger(vm->dataStack);
+ void *address = (void *)ficlStackPopPointer(vm->dataStack);
+
+ clearerr(ff->f);
+ if (fwrite(address, 1, length, ff->f) == length)
+ fwrite("\n", 1, 1, ff->f);+ pushIor(vm, ferror(ff->f) == 0);
+}
+
+
+
+static void ficlPrimitiveRepositionFile(ficlVm *vm) /* ( ud fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
+
+ pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0);
+}
+
+
+
+static void ficlPrimitiveFlushFile(ficlVm *vm) /* ( fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ pushIor(vm, fflush(ff->f) == 0);
+}
+
+
+
+#if FICL_PLATFORM_HAS_FTRUNCATE
+
+static void ficlPrimitiveResizeFile(ficlVm *vm) /* ( ud fileid -- ior ) */
+{+ ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack);
+ size_t ud = (size_t)ficlStackPopInteger(vm->dataStack);
+
+ pushIor(vm, ficlFileTruncate(ff, ud) == 0);
+}
+
+#endif /* FICL_PLATFORM_HAS_FTRUNCATE */
+
+#endif /* FICL_WANT_FILE */
+
+
+
+void ficlSystemCompileFile(ficlSystem *system)
+{+#if !FICL_WANT_FILE
+ FICL_IGNORE(system);
+#else
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+ ficlDictionarySetPrimitive(dictionary, "create-file", ficlPrimitiveCreateFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "open-file", ficlPrimitiveOpenFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "close-file", ficlPrimitiveCloseFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "include-file", ficlPrimitiveIncludeFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "read-file", ficlPrimitiveReadFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "read-line", ficlPrimitiveReadLine, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "write-file", ficlPrimitiveWriteFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "write-line", ficlPrimitiveWriteLine, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-position", ficlPrimitiveFilePosition, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-size", ficlPrimitiveFileSize, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "reposition-file", ficlPrimitiveRepositionFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "file-status", ficlPrimitiveFileStatus, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "flush-file", ficlPrimitiveFlushFile, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetPrimitive(dictionary, "delete-file", ficlPrimitiveDeleteFile, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "rename-file", ficlPrimitiveRenameFile, FICL_WORD_DEFAULT);
+
+#if FICL_PLATFORM_HAS_FTRUNCATE
+ ficlDictionarySetPrimitive(dictionary, "resize-file", ficlPrimitiveResizeFile, FICL_WORD_DEFAULT);
+
+ ficlDictionarySetConstant(environment, "file", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "file-ext", FICL_TRUE);
+#else /* FICL_PLATFORM_HAS_FTRUNCATE */
+ ficlDictionarySetConstant(environment, "file", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "file-ext", FICL_FALSE);
+#endif /* FICL_PLATFORM_HAS_FTRUNCATE */
+
+#endif /* !FICL_WANT_FILE */
+}
--- a/float.c
+++ b/float.c
@@ -1,1062 +1,469 @@
-/*******************************************************************
-** 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.
-*/
-
-#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);
-
- 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;
-}
\ No newline at end of file
+/*******************************************************************
+** 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.9 2010/08/12 13:57:22 asau Exp $
+*******************************************************************/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include "ficl.h"
+
+#if FICL_WANT_FLOAT
+
+
+/*******************************************************************
+** Create a floating point constant.
+** fconstant ( r -"name"- )
+*******************************************************************/
+static void ficlPrimitiveFConstant(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
+}
+
+
+ficlWord *ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name, float value)
+{+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppendConstantInstruction(dictionary, s, ficlInstructionFConstantParen, *(ficlInteger *)(&value));
+}
+
+
+ficlWord *ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name, float value)
+{+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySetConstantInstruction(dictionary, s, ficlInstructionFConstantParen, *(ficlInteger *)(&value));
+}
+
+
+
+
+static void ficlPrimitiveF2Constant(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlString name = ficlVmGetWord(vm);
+
+ FICL_STACK_CHECK(vm->floatStack, 2, 0);
+
+ ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)ficlInstructionF2ConstantParen, FICL_WORD_DEFAULT);
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
+ ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
+}
+
+
+ficlWord *ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name, double value)
+{+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionaryAppend2ConstantInstruction(dictionary, s, ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value));
+}
+
+
+ficlWord *ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name, double value)
+{+ ficlString s;
+ FICL_STRING_SET_FROM_CSTRING(s, name);
+ return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value));
+}
+
+
+/*******************************************************************
+** Display a float in decimal format.
+** f. ( r -- )
+*******************************************************************/
+static void ficlPrimitiveFDot(ficlVm *vm)
+{+ float f;
+
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
+
+ f = ficlStackPopFloat(vm->floatStack);
+ sprintf(vm->pad,"%#f ",f);
+ ficlVmTextOut(vm, vm->pad);
+}
+
+/*******************************************************************
+** Display a float in engineering format.
+** fe. ( r -- )
+*******************************************************************/
+static void ficlPrimitiveEDot(ficlVm *vm)
+{+ float f;
+
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
+
+ f = ficlStackPopFloat(vm->floatStack);
+ sprintf(vm->pad,"%#e ",f);
+ ficlVmTextOut(vm, vm->pad);
+}
+
+/**************************************************************************
+ d i s p l a y FS t a c k
+** Display the parameter stack (code for "f.s")
+** f.s ( -- )
+**************************************************************************/
+struct stackContext
+{+ ficlVm *vm;
+ int count;
+};
+
+static ficlInteger ficlFloatStackDisplayCallback(void *c, ficlCell *cell)
+{+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[64];
+ sprintf(buffer, "[0x%08x %3d] %16f (0x%08x)\n", cell, context->count++, (double)(cell->f), cell->i);
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+
+
+void ficlVmDisplayFloatStack(ficlVm *vm)
+{+ struct stackContext context;
+ context.vm = vm;
+ context.count = 0;
+ ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback, &context);
+ return;
+}
+
+
+
+/*******************************************************************
+** Do float stack depth.
+** fdepth ( -- n )
+*******************************************************************/
+static void ficlPrimitiveFDepth(ficlVm *vm)
+{+ int i;
+
+ FICL_STACK_CHECK(vm->dataStack, 0, 1);
+
+ i = ficlStackDepth(vm->floatStack);
+ ficlStackPushInteger(vm->dataStack, i);
+}
+
+/*******************************************************************
+** Compile a floating point literal.
+*******************************************************************/
+static void ficlPrimitiveFLiteralImmediate(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlCell cell;
+
+
+ FICL_STACK_CHECK(vm->floatStack, 1, 0);
+
+
+ cell = ficlStackPop(vm->floatStack);
+ if (cell.f == 1.0f)
+ {+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1);
+ }
+ else if (cell.f == 0.0f)
+ {+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0);
+ }
+ else if (cell.f == -1.0f)
+ {+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1);
+ }
+ else
+ {+ ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFLiteralParen);
+ ficlDictionaryAppendCell(dictionary, cell);
+ }
+}
+
+/**************************************************************************
+ 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
+** vm -- Virtual Machine pointer.
+** s -- String to parse.
+** Returns 1 if successful, 0 if not.
+**************************************************************************/
+int ficlVmParseFloatNumber( ficlVm *vm, ficlString s)
+{+ unsigned char c;
+ unsigned char digit;
+ char *trace;
+ ficlUnsigned length;
+ float power;
+ float accum = 0.0f;
+ float mant = 0.1f;
+ ficlInteger exponent = 0;
+ char flag = 0;
+ FloatParseState estate = FPS_START;
+
+
+ FICL_STACK_CHECK(vm->floatStack, 0, 1);
+
+
+ /*
+ ** floating point numbers only allowed in base 10
+ */
+ if (vm->base != 10)
+ return(0);
+
+
+ trace = FICL_STRING_GET_POINTER(s);
+ length = FICL_STRING_GET_LENGTH(s);
+
+ /* Loop through the string's characters. */
+ while ((length--) && ((c = *trace++) != 0))
+ {+ switch (estate)
+ {+ /* At start of the number so look for a sign. */
+ case FPS_START:
+ {+ estate = FPS_ININT;
+ if (c == '-')
+ {+ flag |= NUMISNEG;
+ break;
+ }
+ if (c == '+')
+ {+ break;
+ }
+ } /* Note! Drop through to FPS_ININT */
+ /*
+ **Converting integer part of number.
+ ** Only allow digits, decimal and 'E'.
+ */
+ case FPS_ININT:
+ {+ if (c == '.')
+ {+ estate = FPS_INMANT;
+ }
+ else if ((c == 'e') || (c == 'E'))
+ {+ estate = FPS_STARTEXP;
+ }
+ else
+ {+ digit = (unsigned char)(c - '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 ((c == 'e') || (c == 'E'))
+ {+ estate = FPS_STARTEXP;
+ }
+ else
+ {+ digit = (unsigned char)(c - '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 (c == '-')
+ {+ flag |= EXPISNEG;
+ break;
+ }
+ else if (c == '+')
+ {+ break;
+ }
+ } /* Note! Drop through to FPS_INEXP */
+ /*
+ ** Processing the exponent part of number.
+ ** Only allow digits.
+ */
+ case FPS_INEXP:
+ {+ digit = (unsigned char)(c - '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;
+ }
+
+ ficlStackPushFloat(vm->floatStack, accum);
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ ficlPrimitiveFLiteralImmediate(vm);
+
+ return(1);
+}
+
+
+#if FICL_WANT_LOCALS
+
+static void ficlPrimitiveFLocalParen(ficlVm *vm)
+{+ ficlLocalParen(vm, FICL_FALSE, FICL_TRUE);
+}
+
+static void ficlPrimitiveF2LocalParen(ficlVm *vm)
+{+ ficlLocalParen(vm, FICL_TRUE, FICL_TRUE);
+}
+
+#endif /* FICL_WANT_LOCALS */
+
+#endif /* FICL_WANT_FLOAT */
+
+/**************************************************************************
+** Add float words to a system's dictionary.
+** system -- Pointer to the Ficl sytem to add float words to.
+**************************************************************************/
+void ficlSystemCompileFloat(ficlSystem *system)
+{+#if FICL_WANT_FLOAT
+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+ ficlDictionarySetPrimitive(dictionary, "fconstant", ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fvalue", ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f2constant", ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f2value", ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fdepth", ficlPrimitiveFDepth, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fliteral", ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE);
+ ficlDictionarySetPrimitive(dictionary, "f.", ficlPrimitiveFDot, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "f.s", ficlVmDisplayFloatStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "fe.", ficlPrimitiveEDot, FICL_WORD_DEFAULT);
+
+#if FICL_WANT_LOCALS
+ ficlDictionarySetPrimitive(dictionary, "(flocal)", ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY);
+ ficlDictionarySetPrimitive(dictionary, "(f2local)", ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY);
+#endif /* FICL_WANT_LOCALS */
+
+ /*
+ Missing words:
+
+ d>f
+ f>d
+ falign
+ faligned
+ float+
+ floats
+ floor
+ fmax
+ fmin
+*/
+
+ ficlDictionarySetConstant(environment, "floating", FICL_FALSE); /* not all required words are present */
+ ficlDictionarySetConstant(environment, "floating-ext", FICL_FALSE);
+ ficlDictionarySetConstant(environment, "floating-stack", system->stackSize);
+#else /* FICL_WANT_FLOAT */
+ /* get rid of unused parameter warning */
+ system = NULL;
+#endif
+ return;
+}
--- a/math64.c
+++ /dev/null
@@ -1,559 +1,0 @@
-/*******************************************************************
-** m a t h 6 4 . c
-** Forth Inspired Command Language - 64 bit math support routines
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 25 January 1998
-** Rev 2.03: Support for 128 bit DP math. This file really ouught to
-** be renamed!
-** $Id: math64.c,v 1.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.
-*/
-
-#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
-
--- a/math64.h
+++ /dev/null
@@ -1,86 +1,0 @@
-/*******************************************************************
-** m a t h 6 4 . h
-** Forth Inspired Command Language - 64 bit math support routines
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 25 January 1998
-** $Id: math64.h,v 1.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.
-*/
-
-#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
-
--- a/prefix.c
+++ b/prefix.c
@@ -1,197 +1,178 @@
-/*******************************************************************
-** 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.
-*/
-
-#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 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;
-}
+/*******************************************************************
+** 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.7 2010/08/12 13:57:22 asau Exp $
+*******************************************************************/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <string.h>
+#include <ctype.h>
+#include "ficl.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 corresponding
+** code against the remainder of the word and returns true.
+**************************************************************************/
+int ficlVmParsePrefix(ficlVm *vm, ficlString s)
+{+ int i;
+ ficlHash *hash;
+ ficlWord *word = ficlSystemLookup(vm->callback.system, list_name);
+
+ /*
+ ** Make sure we found the prefix dictionary - otherwise silently fail
+ ** If forth-wordlist is not in the search order, we won't find the prefixes.
+ */
+ if (!word)
+ return FICL_FALSE;
+
+ hash = (ficlHash *)(word->param[0].p);
+ /*
+ ** Walk the list looking for a match with the beginning of the incoming token
+ */
+ for (i = 0; i < (int)hash->size; i++)
+ {+ word = hash->table[i];
+ while (word != NULL)
+ {+ int n;
+ n = word->length;
+ /*
+ ** If we find a match, adjust the TIB to give back the non-prefix characters
+ ** and execute the prefix word.
+ */
+ if (!ficlStrincmp(FICL_STRING_GET_POINTER(s), word->name, (ficlUnsigned)n))
+ {+ /* (sadler) fixed off-by-one error when the token has no trailing space in the TIB */
+ ficlVmSetTibIndex(vm, s.text + n - vm->tib.text);
+ ficlVmExecuteWord(vm, word);
+
+ return FICL_TRUE;
+ }
+ word = word->link;
+ }
+ }
+
+ return FICL_FALSE;
+}
+
+
+static void ficlPrimitiveTempBase(ficlVm *vm)
+{+ int oldbase = vm->base;
+ ficlString number = ficlVmGetWord0(vm);
+ int base = ficlStackPopInteger(vm->dataStack);
+
+ vm->base = base;
+ if (!ficlVmParseNumber(vm, number))
+ ficlVmThrowError(vm, "%.*s not recognized", FICL_STRING_GET_LENGTH(number), FICL_STRING_GET_POINTER(number));
+
+ vm->base = oldbase;
+ return;
+}
+
+
+
+/**************************************************************************
+ 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 ficlSystemCompilePrefix(ficlSystem *system)
+{+ ficlDictionary *dictionary = system->dictionary;
+ ficlHash *hash;
+
+ /*
+ ** Create a named wordlist for prefixes to reside in...
+ ** Since we're doing a special kind of search, make it
+ ** a single bucket hashtable - hashing does not help here.
+ */
+ hash = ficlDictionaryCreateWordlist(dictionary, 1);
+ hash->name = list_name;
+ ficlDictionaryAppendConstantPointer(dictionary, list_name, hash);
+
+ /*
+ ** Put __tempbase in the forth-wordlist
+ */
+ ficlDictionarySetPrimitive(dictionary, "__tempbase", ficlPrimitiveTempBase, FICL_WORD_DEFAULT);
+
+ /*
+ ** If you want to add some prefixes at compilation-time, copy this line to the top of this function:
+ **
+ ficlHash *oldCompilationWordlist;
+
+ **
+ ** then copy this code to the bottom, just above the return:
+ **
+
+ oldCompilationWordlist = dictionary->compilationWordlist;
+ dictionary->compilationWordlist = hash;
+ ficlDictionarySetPrimitive(dictionary, YOUR WORD HERE, FICL_WORD_DEFAULT);
+ dictionary->compilationWordlist = oldCompilationWordlist;
+
+ **
+ ** and substitute in your own actual calls to ficlDictionarySetPrimitive() as needed.
+ **
+ ** Or--better yet--do it in your own code, so you don't have to re-modify the Ficl
+ ** source code every time we cut a new release!
+ */
+
+ return;
+}
--- a/search.c
+++ b/search.c
@@ -1,391 +1,399 @@
-/*******************************************************************
-** 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.
-*/
-
-#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;
-}
-
+/*******************************************************************
+** 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.10 2010/08/12 13:57:22 asau Exp $
+*******************************************************************/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <string.h>
+#include "ficl.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 ficlPrimitiveDefinitions(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ FICL_VM_ASSERT(vm, dictionary);
+ if (dictionary->wordlistCount < 1)
+ {+ ficlVmThrowError(vm, "DEFINITIONS error - empty search order");
+ }
+
+ dictionary->compilationWordlist = dictionary->wordlists[dictionary->wordlistCount-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 ficlPrimitiveForthWordlist(ficlVm *vm)
+{+ ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
+ ficlStackPushPointer(vm->dataStack, hash);
+ return;
+}
+
+
+/**************************************************************************
+ g e t - c u r r e n t
+** SEARCH ( -- wid )
+** Return wid, the identifier of the compilation word list.
+**************************************************************************/
+static void ficlPrimitiveGetCurrent(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ ficlStackPushPointer(vm->dataStack, dictionary->compilationWordlist);
+ ficlDictionaryLock(dictionary, FICL_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 ficlPrimitiveGetOrder(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ int wordlistCount = dictionary->wordlistCount;
+ int i;
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ for (i = 0; i < wordlistCount; i++)
+ {+ ficlStackPushPointer(vm->dataStack, dictionary->wordlists[i]);
+ }
+
+ ficlStackPushUnsigned(vm->dataStack, wordlistCount);
+ ficlDictionaryLock(dictionary, FICL_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 ficlPrimitiveSearchWordlist(ficlVm *vm)
+{+ ficlString name;
+ ficlUnsigned16 hashCode;
+ ficlWord *word;
+ ficlHash *hash = ficlStackPopPointer(vm->dataStack);
+
+ name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack);
+ name.text = ficlStackPopPointer(vm->dataStack);
+ hashCode = ficlHashCode(name);
+
+ ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE);
+ word = ficlHashLookup(hash, name, hashCode);
+ ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE);
+
+ if (word)
+ {+ ficlStackPushPointer(vm->dataStack, word);
+ ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1));
+ }
+ else
+ {+ ficlStackPushUnsigned(vm->dataStack, 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 ficlPrimitiveSetCurrent(ficlVm *vm)
+{+ ficlHash *hash = ficlStackPopPointer(vm->dataStack);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ dictionary->compilationWordlist = hash;
+ ficlDictionaryLock(dictionary, FICL_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 ficlPrimitiveSetOrder(ficlVm *vm)
+{+ int i;
+ int wordlistCount = ficlStackPopInteger(vm->dataStack);
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ if (wordlistCount > FICL_MAX_WORDLISTS)
+ {+ ficlVmThrowError(vm, "set-order error: list would be too large");
+ }
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+
+ if (wordlistCount >= 0)
+ {+ dictionary->wordlistCount = wordlistCount;
+ for (i = wordlistCount-1; i >= 0; --i)
+ {+ dictionary->wordlists[i] = ficlStackPopPointer(vm->dataStack);
+ }
+ }
+ else
+ {+ ficlDictionaryResetSearchOrder(dictionary);
+ }
+
+ ficlDictionaryLock(dictionary, FICL_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 ficlPrimitiveFiclWordlist(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash;
+ ficlUnsigned nBuckets;
+
+ FICL_STACK_CHECK(vm->dataStack, 1, 1);
+
+ nBuckets = ficlStackPopUnsigned(vm->dataStack);
+ hash = ficlDictionaryCreateWordlist(dictionary, nBuckets);
+ ficlStackPushPointer(vm->dataStack, hash);
+ return;
+}
+
+
+/**************************************************************************
+ S E A R C H >
+** Ficl ( -- wid )
+** Pop wid off the search order. Error if the search order is empty
+**************************************************************************/
+static void ficlPrimitiveSearchPop(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ int wordlistCount;
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ wordlistCount = dictionary->wordlistCount;
+ if (wordlistCount == 0)
+ {+ ficlVmThrowError(vm, "search> error: empty search order");
+ }
+ ficlStackPushPointer(vm->dataStack, dictionary->wordlists[--dictionary->wordlistCount]);
+ ficlDictionaryLock(dictionary, FICL_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 ficlPrimitiveSearchPush(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+
+ ficlDictionaryLock(dictionary, FICL_TRUE);
+ if (dictionary->wordlistCount > FICL_MAX_WORDLISTS)
+ {+ ficlVmThrowError(vm, ">search error: search order overflow");
+ }
+ dictionary->wordlists[dictionary->wordlistCount++] = ficlStackPopPointer(vm->dataStack);
+ ficlDictionaryLock(dictionary, FICL_FALSE);
+ return;
+}
+
+
+/**************************************************************************
+ W I D - G E T - N A M E
+** Ficl ( wid -- c-addr u )
+** Get wid's (optional) name and push onto stack as a counted string
+**************************************************************************/
+static void ficlPrimitiveWidGetName(ficlVm *vm)
+{+ ficlHash *hash;
+ char *name;
+ ficlInteger length;
+
+ hash = ficlVmPop(vm).p;
+ name = hash->name;
+
+ if (name != NULL)
+ length = strlen(name);
+ else
+ length = 0;
+
+ ficlVmPush(vm, FICL_LVALUE_TO_CELL(name));
+ ficlVmPush(vm, FICL_LVALUE_TO_CELL(length));
+ return;
+}
+
+/**************************************************************************
+ W I D - S E T - N A M E
+** Ficl ( wid c-addr -- )
+** Set wid's name pointer to the \0 terminated string address supplied
+**************************************************************************/
+static void ficlPrimitiveWidSetName(ficlVm *vm)
+{+ char *name = (char *)ficlVmPop(vm).p;
+ ficlHash *hash = ficlVmPop(vm).p;
+ hash->name = name;
+ 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 ficlPrimitiveSetParentWid(ficlVm *vm)
+{+ ficlHash *parent, *child;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ child = (ficlHash *)ficlStackPopPointer(vm->dataStack);
+ parent = (ficlHash *)ficlStackPopPointer(vm->dataStack);
+
+ 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 ficlSystemCompileSearch(ficlSystem *system)
+{+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+
+ /*
+ ** optional SEARCH-ORDER word set
+ */
+ ficlDictionarySetPrimitive(dictionary, ">search", ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "search>", ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "definitions",
+ ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
+ ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "get-current",
+ ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "get-order", ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "search-wordlist",
+ ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "set-current",
+ ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "set-order", ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
+ ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);
+
+ /*
+ ** Set SEARCH environment query values
+ */
+ ficlDictionarySetConstant(environment, "search-order", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "search-order-ext", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "wordlists", FICL_MAX_WORDLISTS);
+
+ ficlDictionarySetPrimitive(dictionary, "wid-get-name", ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "wid-set-name", ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "wid-set-super",
+ ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
+ return;
+}
+
--- a/softcore.c
+++ b/softcore.c
@@ -1,1028 +1,2551 @@
-/*******************************************************************
-** s o f t c o r e . c
-** Forth Inspired Command Language -
-** Words from CORE set written in FICL
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 27 December 1997
-** Last update: Sun Dec 2 21:15:18 2001
-*******************************************************************/
-/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
-** Make changes to the .fr files in ficl/softwords instead.
-** This file contains definitions that are compiled into the
-** system dictionary by the first virtual machine to be created.
-** Created automagically by ficl/softwords/softcore.pl
-*/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
-** All rights reserved.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** I am interested in hearing from anyone who uses ficl. If you have
-** a problem, a success story, a defect, an enhancement request, or
-** if you would like to contribute to the ficl release, please send
-** contact me by email at the address above.
-**
-** L I C E N S E and D I S C L A I M E R
-**
-** Redistribution and use in source and binary forms, with or without
-** modification, are permitted provided that the following conditions
-** are met:
-** 1. Redistributions of source code must retain the above copyright
-** notice, this list of conditions and the following disclaimer.
-** 2. Redistributions in binary form must reproduce the above copyright
-** notice, this list of conditions and the following disclaimer in the
-** documentation and/or other materials provided with the distribution.
-**
-** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-** SUCH DAMAGE.
-*/
-
-
-#include "ficl.h"
-
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS
-/*
-** ficl/softwords/softcore.fr
-** FICL soft extensions
-** John Sadler (john_sadler@alum.mit.edu)
-** September, 1998
-*/
-/*
-** Ficl USER variables
-** See words.c for primitive def'n of USER
-*/
- ".( loading ficl soft extensions ) cr "
-#if FICL_WANT_USER
- "variable nUser 0 nUser ! "
- ": user "
- "nUser dup @ user 1 swap +! ; "
-#endif
-/*
-** ficl extras
-*/
- ": empty depth 0 ?do drop loop ; "
- ": cell- [ 1 cells ] literal - ; "
- ": -rot 2 -roll ; "
-/*
-** CORE
-*/
- ": abs "
- "dup 0< if negate endif ; "
- "decimal 32 constant bl "
- ": space bl emit ; "
- ": spaces 0 ?do space loop ; "
- ": abort\" "
- "state @ if "
- "postpone if "
- "postpone .\" "
- "postpone cr "
- "-2 "
- "postpone literal "
- "postpone throw "
- "postpone endif "
- "else "
- "[char] \" parse "
- "rot if "
- "type "
- "cr "
- "-2 throw "
- "else "
- "2drop "
- "endif "
- "endif "
- "; immediate "
-/*
-** CORE EXT
-*/
- ".( loading CORE EXT words ) cr "
- "0 constant false "
- "false invert constant true "
- ": <> = 0= ; "
- ": 0<> 0= 0= ; "
- ": compile, , ; "
- ": convert char+ 65535 >number drop ; "
- ": erase 0 fill ; "
- "variable span "
- ": expect accept span ! ; "
- ": nip swap drop ; "
- ": tuck swap over ; "
- ": within over - >r - r> u< ; "
-/*
-** LOCAL EXT word set
-*/
-#if FICL_WANT_LOCALS
- ": locals| "
- "begin "
- "bl word count "
- "dup 0= abort\" where's the delimiter??\" "
- "over c@ "
- "[char] | - over 1- or "
- "while "
- "(local) "
- "repeat 2drop 0 0 (local) "
- "; immediate "
- ": local bl word count (local) ; immediate "
- ": 2local bl word count (2local) ; immediate "
- ": end-locals 0 0 (local) ; immediate "
-#endif
-/*
-** TOOLS word set...
-*/
- ": ? @ . ; "
- ": dump "
- "0 ?do "
- "dup c@ . 1+ "
- "i 7 and 7 = if cr endif "
- "loop drop "
- "; "
-/*
-** SEARCH+EXT words and ficl helpers
-*/
- ".( loading SEARCH & SEARCH-EXT words ) cr "
- ": brand-wordlist last-word >name drop wid-set-name ; "
- ": ficl-named-wordlist "
- "ficl-wordlist dup create , brand-wordlist does> @ ; "
- ": wordlist "
- "1 ficl-wordlist ; "
- ": ficl-set-current "
- "get-current swap set-current ; "
- ": do-vocabulary "
- "does> @ search> drop >search ; "
- ": ficl-vocabulary "
- "ficl-named-wordlist do-vocabulary ; "
- ": vocabulary "
- "1 ficl-vocabulary ; "
- ": previous search> drop ; "
- "1 ficl-named-wordlist hidden "
- ": hide hidden dup >search ficl-set-current ; "
- ": also "
- "search> dup >search >search ; "
- ": forth "
- "search> drop "
- "forth-wordlist >search ; "
- ": only "
- "-1 set-order ; "
- "hide "
- ": list-wid "
- "dup wid-get-name "
- "?dup if "
- "type drop "
- "else "
- "drop .\" (unnamed wid) \" x. "
- "endif cr "
- "; "
- "set-current "
- ": order "
- ".\" Search:\" cr "
- "get-order 0 ?do 3 spaces list-wid loop cr "
- ".\" Compile: \" get-current list-wid cr "
- "; "
- ": debug ' debug-xt ; immediate "
- ": on-step .\" S: \" .s cr ; "
- ": strdup "
- "0 locals| addr2 length c-addr | end-locals "
- "length 1 + allocate "
- "0= if "
- "to addr2 "
- "c-addr addr2 length move "
- "addr2 length 0 "
- "else "
- "0 -1 "
- "endif "
- "; "
- ": strcat "
- "0 locals| b-length b-u b-addr a-u a-addr | end-locals "
- "b-u to b-length "
- "b-addr a-addr a-u + b-length move "
- "a-addr a-u b-length + "
- "; "
- ": strcpy "
- "locals| b-u b-addr a-u a-addr | end-locals "
- "a-addr 0 b-addr b-u strcat "
- "; "
- "previous "
-/*
-** E N D S O F T C O R E . F R
-*/
-#if FICL_WANT_LOCALS
-/*
-** ficl/softwords/jhlocal.fr
-** stack comment style local syntax...
-*/
- ".( loading Johns-Hopkins locals ) cr "
- "hide "
- "0 constant zero "
- ": ?-- "
- "2dup s\" --\" compare 0= ; "
- ": ?} "
- "2dup s\" }\" compare 0= ; "
- ": ?| "
- "2dup s\" |\" compare 0= ; "
- ": ?2loc "
- "over dup c@ [char] 2 = "
- "swap 1+ c@ [char] : = and "
- "if "
- "2 - swap char+ char+ swap "
- "true "
- "else "
- "false "
- "endif "
- "; "
- ": ?delim "
- "?| if 2drop 1 exit endif "
- "?-- if 2drop 2 exit endif "
- "?} if 2drop 3 exit endif "
- "dup 0= "
- "if 2drop 4 exit endif "
- "0 "
- "; "
- "set-current "
- ": { "
- "0 dup locals| locstate | "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "0= while "
- "rot 1+ "
- "repeat "
- "0 ?do "
- "?2loc if (2local) else (local) endif "
- "loop "
- "locstate 1 = if "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "0= while "
- "?2loc if "
- "postpone zero postpone zero (2local) "
- "else "
- "postpone zero (local) "
- "endif "
- "repeat "
- "endif "
- "0 0 (local) "
- "locstate 2 = if "
- "begin "
- "parse-word "
- "?delim dup to locstate "
- "0= while "
- "2drop "
- "repeat "
- "endif "
- "locstate 3 <> abort\" syntax error in { } local line\" "
- "; immediate compile-only "
- "previous "
-#endif
-/*
-** ficl/softwords/marker.fr
-** Ficl implementation of CORE EXT MARKER
-*/
- ".( loading MARKER ) cr "
- ": marker "
- "create "
- "get-current , "
- "get-order dup , "
- "0 ?do , loop "
- "does> "
- "0 set-order "
- "dup body> >name drop "
- "here - allot "
- "dup @ "
- "dup set-current forget-wid "
- "cell+ dup @ swap "
- "over cells + swap "
- "0 ?do "
- "dup @ dup "
- ">search forget-wid "
- "cell- "
- "loop "
- "drop "
- "; "
-/*
-**
-** Prefix words for ficl
-** submitted by Larry Hastings, larry@hastings.org
-**
-*/
- "variable save-current "
- ": start-prefixes get-current save-current ! <prefixes> set-current ; "
- ": end-prefixes save-current @ set-current ; "
- ": show-prefixes <prefixes> >search words search> drop ; "
-#if (FICL_EXTENDED_PREFIX)
- "start-prefixes "
- ": \" postpone s\" ; immediate "
- ": .( .( ; "
-/*
-** add 0b, 0o, 0d, and 0x as prefixes
-** these temporarily shift the base to 2, 8, 10, and 16 respectively
-** and consume the next number in the input stream, pushing/compiling
-** as normal
-*/
- ": 0b 2 __tempbase ; immediate "
- ": 0o 8 __tempbase ; immediate "
- "end-prefixes "
-#endif
-/*
-** ficl/softwords/ifbrack.fr
-** ANS conditional compile directives [if] [else] [then]
-** Requires ficl 2.0 or greater...
-*/
- "hide "
- ": ?[if] "
- "2dup s\" [if]\" compare-insensitive 0= "
- "; "
- ": ?[else] "
- "2dup s\" [else]\" compare-insensitive 0= "
- "; "
- ": ?[then] "
- "2dup s\" [then]\" compare-insensitive 0= >r "
- "2dup s\" [endif]\" compare-insensitive 0= r> "
- "or "
- "; "
- "set-current "
- ": [else] "
- "1 "
- "begin "
- "begin "
- "parse-word dup while "
- "?[if] if "
- "2drop 1+ "
- "else "
- "?[else] if "
- "2drop 1- dup if 1+ endif "
- "else "
- "?[then] if 2drop 1- else 2drop endif "
- "endif "
- "endif ?dup 0= if exit endif "
- "repeat 2drop "
- "refill 0= until "
- "drop "
- "; immediate "
- ": [if] "
- "0= if postpone [else] then ; immediate "
- ": [then] ; immediate "
- ": [endif] ; immediate "
- "previous "
-#if FICL_WANT_OOP
-/*
-** ficl/softwords/oo.fr
-** F I C L O - O E X T E N S I O N S
-** john sadler aug 1998
-*/
- ".( loading ficl O-O extensions ) cr "
- "17 ficl-vocabulary oop "
- "also oop definitions "
- "user current-class "
- "0 current-class ! "
-/*
-** L A T E B I N D I N G
-*/
- "hide "
- ": parse-method "
- "parse-word "
- "postpone sliteral "
- "; compile-only "
- ": lookup-method { class 2:name -- class xt } "
- "name class cell+ @ "
- "search-wordlist "
- "0= if "
- "name type .\" not found in \" "
- "class body> >name type "
- "cr abort "
- "endif "
- "class swap "
- "; "
- ": find-method-xt "
- "parse-word lookup-method "
- "; "
- "set-current "
- ": catch-method "
- "lookup-method catch "
- "; "
- ": exec-method "
- "lookup-method execute "
- "; "
- ": --> "
- "state @ 0= if "
- "find-method-xt execute "
- "else "
- "parse-method postpone exec-method "
- "endif "
- "; immediate "
- ": c-> "
- "state @ 0= if "
- "find-method-xt catch "
- "else "
- "parse-method postpone catch-method "
- "endif "
- "; immediate "
- ": method create does> body> >name lookup-method execute ; "
-/*
-** E A R L Y B I N D I N G
-*/
- "1 ficl-named-wordlist instance-vars "
- "instance-vars dup >search ficl-set-current "
- ": => "
- "drop find-method-xt compile, drop "
- "; immediate compile-only "
- ": my=> "
- "current-class @ dup postpone => "
- "; immediate compile-only "
- ": my=[ "
- "current-class @ "
- "begin "
- "parse-word 2dup "
- "s\" ]\" compare while "
- "lookup-method "
- "dup compile, "
- "dup ?object if "
- "nip >body cell+ @ "
- "else "
- "drop "
- "endif "
- "repeat 2drop drop "
- "; immediate compile-only "
-/*
-** I N S T A N C E V A R I A B L E S
-*/
- ": do-instance-var "
- "does> "
- "nip @ + "
- "; "
- ": addr-units: "
- "create over , + "
- "do-instance-var "
- "; "
- ": chars: "
- "chars addr-units: ; "
- ": char: "
- "1 chars: ; "
- ": cells: "
- "cells >r aligned r> addr-units: "
- "; "
- ": cell: "
- "1 cells: ; "
- ": do-aggregate "
- "objectify "
- "does> "
- "2@ "
- "2swap drop "
- "+ swap "
- "; "
- ": obj: { offset class meta -- offset' } "
- "create offset , class , "
- "class meta --> get-size offset + "
- "do-aggregate "
- "; "
- ": array: "
- "locals| meta class nobjs offset | "
- "create offset , class , "
- "class meta --> get-size nobjs * offset + "
- "do-aggregate "
- "; "
- ": ref: "
- "locals| meta class offset | "
- "create offset , class , "
- "offset cell+ "
- "does> "
- "2@ "
- "2swap drop + @ swap "
- "; "
-#if FICL_WANT_VCALL
- ": vcall: "
- "current-class @ 8 + dup @ dup 1+ rot ! "
- "create , , "
- "does> "
- "nip 2@ vcall "
- "; "
- ": vcallr: 0x80000000 or vcall: ; "
-#if FICL_WANT_FLOAT
- ": vcallf: "
- "0x80000000 or "
- "current-class @ 8 + dup @ dup 1+ rot ! "
- "create , , "
- "does> "
- "nip 2@ vcall f> "
- "; "
-#endif /* FLOAT */
-#endif /* VCALL */
- ": end-class "
- "swap ! set-current "
- "search> drop "
- "; "
- ": suspend-class end-class ; "
- "set-current previous "
- ": do-do-instance "
- "s\" : .do-instance does> [ current-class @ ] literal ;\" "
- "evaluate "
- "; "
-/*
-** M E T A C L A S S
-*/
- ":noname "
- "wordlist "
- "create "
- "immediate "
- "0 , "
- "dup , "
-#if FICL_WANT_VCALL
- "4 cells , "
-#else
- "3 cells , "
-#endif
- "ficl-set-current "
- "does> dup "
- "; execute metaclass "
- "metaclass drop cell+ @ brand-wordlist "
- "metaclass drop current-class ! "
- "do-do-instance "
- "instance-vars >search "
- "create .super "
- "0 cells , do-instance-var "
- "create .wid "
- "1 cells , do-instance-var "
-#if FICL_WANT_VCALL
- "create .vtCount "
- "2 cells , do-instance-var "
- "create .size "
- "3 cells , do-instance-var "
-#else
- "create .size "
- "2 cells , do-instance-var "
-#endif
- ": get-size metaclass => .size @ ; "
- ": get-wid metaclass => .wid @ ; "
- ": get-super metaclass => .super @ ; "
-#if FICL_WANT_VCALL
- ": get-vtCount metaclass => .vtCount @ ; "
- ": get-vtAdd metaclass => .vtCount ; "
-#endif
- ": instance "
- "locals| meta parent | "
- "create "
- "here parent --> .do-instance "
- "parent meta metaclass => get-size "
- "allot "
- "; "
- ": array "
- "locals| meta parent nobj | "
- "create nobj "
- "here parent --> .do-instance "
- "parent meta metaclass => get-size "
- "nobj * allot "
- "; "
- ": new "
- "metaclass => instance --> init "
- "; "
- ": new-array "
- "metaclass => array "
- "--> array-init "
- "; "
- ": alloc "
- "locals| meta class | "
- "class meta metaclass => get-size allocate "
- "abort\" allocate failed \" "
- "class 2dup --> init "
- "; "
- ": alloc-array "
- "locals| meta class nobj | "
- "class meta metaclass => get-size "
- "nobj * allocate "
- "abort\" allocate failed \" "
- "nobj over class --> array-init "
- "class "
- "; "
- ": allot { 2:this -- 2:instance } "
- "here "
- "this my=> get-size allot "
- "this drop 2dup --> init "
- "; "
- ": allot-array { nobj 2:this -- 2:instance } "
- "here "
- "this my=> get-size nobj * allot "
- "this drop 2dup "
- "nobj -rot --> array-init "
- "; "
- ": ref "
- "drop create , , "
- "does> 2@ "
- "; "
- ": resume-class { 2:this -- old-wid addr[size] size } "
- "this --> .wid @ ficl-set-current "
- "this --> .size dup @ "
- "instance-vars >search "
- "; "
- ": sub "
- "wordlist "
- "locals| wid meta parent | "
- "parent meta metaclass => get-wid "
- "wid wid-set-super "
- "create immediate "
- "wid brand-wordlist "
- "here current-class ! "
- "parent , "
- "wid , "
-#if FICL_WANT_VCALL
- "parent meta --> get-vtCount , "
-#endif
- "here parent meta --> get-size dup , "
- "metaclass => .do-instance "
- "wid ficl-set-current -rot "
- "do-do-instance "
- "instance-vars >search "
- "; "
- ": offset-of "
- "drop find-method-xt nip >body @ ; "
- ": id "
- "drop body> >name ; "
- ": methods "
- "locals| meta class | "
- "begin "
- "class body> >name type .\" methods:\" cr "
- "class meta --> get-wid >search words cr previous "
- "class meta metaclass => get-super "
- "dup to class "
- "0= until cr "
- "; "
- ": pedigree "
- "locals| meta class | "
- "begin "
- "class body> >name type space "
- "class meta metaclass => get-super "
- "dup to class "
- "0= until cr "
- "; "
- ": see "
- "metaclass => get-wid >search see previous ; "
- ": debug "
- "find-method-xt debug-xt ; "
- "previous set-current "
-/*
-** META is a nickname for the address of METACLASS...
-*/
- "metaclass drop "
- "constant meta "
-/*
-** SUBCLASS is a nickname for a class's SUB method...
-*/
- ": subclass --> sub ; "
-#if FICL_WANT_VCALL
- ": hasvtable 4 + ; immediate "
-#endif
-/*
-** O B J E C T
-*/
- ":noname "
- "wordlist "
- "create immediate "
- "0 , "
- "dup , "
- "0 , "
- "ficl-set-current "
- "does> meta "
- "; execute object "
- "object drop cell+ @ brand-wordlist "
- "object drop current-class ! "
- "do-do-instance "
- "instance-vars >search "
- ": class "
- "nip meta ; "
- ": init "
- "meta "
- "metaclass => get-size "
- "erase ; "
- ": array-init "
- "0 dup locals| &init &next class inst | "
- "class s\" init\" lookup-method to &init "
- "s\" next\" lookup-method to &next "
- "drop "
- "0 ?do "
- "inst class 2dup "
- "&init execute "
- "&next execute drop to inst "
- "loop "
- "; "
- ": free "
- "drop free "
- "abort\" free failed \" "
- "; "
- ": super "
- "meta metaclass => get-super ; "
- ": pedigree "
- "object => class "
- "metaclass => pedigree ; "
- ": size "
- "object => class "
- "metaclass => get-size ; "
- ": methods "
- "object => class "
- "metaclass => methods ; "
- ": index "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size * "
- "inst + class ; "
- ": next "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size "
- "inst + "
- "class ; "
- ": prev "
- "locals| class inst | "
- "inst class "
- "object => class "
- "metaclass => get-size "
- "inst swap - "
- "class ; "
- ": debug "
- "find-method-xt debug-xt ; "
- "previous set-current "
- "only definitions "
- ": oo only also oop definitions ; "
-#endif
-#if (FICL_WANT_OOP)
-/*
-** ficl/softwords/classes.fr
-** F I C L 2 . 0 C L A S S E S
-*/
- ".( loading ficl utility classes ) cr "
- "also oop definitions "
- "object subclass c-ref "
- "cell: .class "
- "cell: .instance "
- ": get "
- "drop 2@ ; "
- ": set "
- "drop 2! ; "
- "end-class "
- "object subclass c-byte "
- "char: .payload "
- ": get drop c@ ; "
- ": set drop c! ; "
- "end-class "
- "object subclass c-2byte "
- "2 chars: .payload "
- ": get drop w@ ; "
- ": set drop w! ; "
- "end-class "
- "object subclass c-4byte "
- "4 chars: .payload "
- ": get drop q@ ; "
- ": set drop q! ; "
- "end-class "
- "object subclass c-cell "
- "cell: .payload "
- ": get drop @ ; "
- ": set drop ! ; "
- "end-class "
-/*
-** C - P T R
-*/
- "object subclass c-ptr "
- "c-cell obj: .addr "
- ": get-ptr "
- "c-ptr => .addr "
- "c-cell => get "
- "; "
- ": set-ptr "
- "c-ptr => .addr "
- "c-cell => set "
- "; "
- ": clr-ptr "
- "0 -rot c-ptr => .addr c-cell => set "
- "; "
- ": ?null "
- "c-ptr => get-ptr 0= "
- "; "
- ": inc-ptr "
- "2dup 2dup "
- "c-ptr => get-ptr -rot "
- "--> @size + -rot "
- "c-ptr => set-ptr "
- "; "
- ": dec-ptr "
- "2dup 2dup "
- "c-ptr => get-ptr -rot "
- "--> @size - -rot "
- "c-ptr => set-ptr "
- "; "
- ": index-ptr { index 2:this -- } "
- "this --> get-ptr "
- "this --> @size index * + "
- "this --> set-ptr "
- "; "
- "end-class "
-/*
-** C - C E L L P T R
-*/
- "c-ptr subclass c-cellPtr "
- ": @size 2drop 1 cells ; "
- ": get "
- "c-ptr => get-ptr @ "
- "; "
- ": set "
- "c-ptr => get-ptr ! "
- "; "
- "end-class "
-/*
-** C - 4 B Y T E P T R
-*/
- "c-ptr subclass c-4bytePtr "
- ": @size 2drop 4 ; "
- ": get "
- "c-ptr => get-ptr q@ "
- "; "
- ": set "
- "c-ptr => get-ptr q! "
- "; "
- "end-class "
-/*
-** C - 2 B Y T E P T R
-*/
- "c-ptr subclass c-2bytePtr "
- ": @size 2drop 2 ; "
- ": get "
- "c-ptr => get-ptr w@ "
- "; "
- ": set "
- "c-ptr => get-ptr w! "
- "; "
- "end-class "
-/*
-** C - B Y T E P T R
-*/
- "c-ptr subclass c-bytePtr "
- ": @size 2drop 1 ; "
- ": get "
- "c-ptr => get-ptr c@ "
- "; "
- ": set "
- "c-ptr => get-ptr c! "
- "; "
- "end-class "
- "previous definitions "
-#endif
-#if (FICL_WANT_OOP)
-/*
-** ficl/softwords/string.fr
-*/
-/*
-** C - S T R I N G
-*/
- ".( loading ficl string class ) cr "
- "also oop definitions "
- "object subclass c-string "
- "c-cell obj: .count "
- "c-cell obj: .buflen "
- "c-ptr obj: .buf "
- "32 constant min-buf "
- ": get-count my=[ .count get ] ; "
- ": set-count my=[ .count set ] ; "
- ": ?empty --> get-count 0= ; "
- ": get-buflen my=[ .buflen get ] ; "
- ": set-buflen my=[ .buflen set ] ; "
- ": get-buf my=[ .buf get-ptr ] ; "
- ": set-buf { ptr len 2:this -- } "
- "ptr this my=[ .buf set-ptr ] "
- "len this my=> set-buflen "
- "; "
- ": clr-buf "
- "0 0 2over my=> set-buf "
- "0 -rot my=> set-count "
- "; "
- ": free-buf { 2:this -- } "
- "this my=> get-buf "
- "?dup if "
- "free "
- "abort\" c-string free failed\" "
- "this my=> clr-buf "
- "endif "
- "; "
- ": size-buf { size 2:this -- } "
- "size 0< abort\" need positive size for size-buf\" "
- "size 0= if "
- "this --> free-buf exit "
- "endif "
- "my=> min-buf size over / 1+ * chars to size "
- "this --> get-buflen 0= "
- "if "
- "size allocate "
- "abort\" out of memory\" "
- "size this --> set-buf "
- "size this --> set-buflen "
- "exit "
- "endif "
- "size this --> get-buflen > if "
- "this --> get-buf size resize "
- "abort\" out of memory\" "
- "size this --> set-buf "
- "endif "
- "; "
- ": set { c-addr u 2:this -- } "
- "u this --> size-buf "
- "u this --> set-count "
- "c-addr this --> get-buf u move "
- "; "
- ": get { 2:this -- c-addr u } "
- "this --> get-buf "
- "this --> get-count "
- "; "
- ": cat { c-addr u 2:this -- } "
- "this --> get-count u + dup >r "
- "this --> size-buf "
- "c-addr this --> get-buf this --> get-count + u move "
- "r> this --> set-count "
- "; "
- ": type { 2:this -- } "
- "this --> ?empty if .\" (empty) \" exit endif "
- "this --> .buf --> get-ptr "
- "this --> .count --> get "
- "type "
- "; "
- ": compare "
- "--> get "
- "2swap "
- "--> get "
- "2swap compare "
- "; "
- ": hashcode "
- "--> get hash "
- "; "
- ": free 2dup --> free-buf object => free ; "
- "end-class "
- "c-string subclass c-hashstring "
- "c-2byte obj: .hashcode "
- ": set-hashcode { 2:this -- } "
- "this --> super --> hashcode "
- "this --> .hashcode --> set "
- "; "
- ": get-hashcode "
- "--> .hashcode --> get "
- "; "
- ": set "
- "2swap 2over --> super --> set "
- "--> set-hashcode "
- "; "
- ": cat "
- "2swap 2over --> super --> cat "
- "--> set-hashcode "
- "; "
- "end-class "
- "previous definitions "
-#endif
-#if FICL_WANT_FILE
-/*
-**
-** File Access words for ficl
-** submitted by Larry Hastings, larry@hastings.org
-**
-*/
- ": r/o 1 ; "
- ": r/w 3 ; "
- ": w/o 2 ; "
- ": bin 8 or ; "
- ": included "
- "r/o bin open-file 0= if "
- "locals| f | end-locals "
- "f include-file "
- "f close-file drop "
- "else "
- "drop "
- "endif "
- "; "
- ": include parse-word included ; immediate "
-#endif
-#endif /* WANT_SOFTWORDS */
- "quit ";
-
-
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
-{
- FICL_VM *pVM = pSys->vmList;
- CELL id = pVM->sourceID;
- int ret = sizeof (softWords);
- assert(pVM);
- pVM->sourceID.i = -1;
- ret = ficlExec(pVM, softWords);
- pVM->sourceID = id;
- if (ret == VM_ERREXIT)
- assert(FALSE);
- return;
-}
-
-
+/*
+** Ficl softcore
+** both uncompressed and Lempel-Ziv compressed versions.
+**
+** Generated 2003/05/05 12:42:30
+**/
+
+#include "ficl.h"
+
+
+static size_t ficlSoftcoreUncompressedSize = 25687; /* not including trailing null */
+
+#if !FICL_WANT_LZ_SOFTCORE
+
+static char ficlSoftcoreUncompressed[] =
+ ": empty ( xn..x1 -- ) depth 0 ?do drop loop ;\n"
+ ": cell- ( addr -- addr ) [ 1 cells ] literal - ;\n"
+ ": -rot ( a b c -- c a b ) 2 -roll ;\n"
+ ": abs ( x -- x )\n"
+ "dup 0< if negate endif ;\n"
+ "decimal 32 constant bl\n"
+ ": space ( -- ) bl emit ;\n"
+ ": spaces ( n -- ) 0 ?do space loop ;\n"
+ ": abort\"\n"
+ "state @ if\n"
+ "postpone if\n"
+ "postpone .\"\n"
+ "postpone cr\n"
+ "-2\n"
+ "postpone literal\n"
+ "postpone throw\n"
+ "postpone endif\n"
+ "else\n"
+ "[char] \" parse\n"
+ "rot if\n"
+ "type\n"
+ "cr\n"
+ "-2 throw\n"
+ "else\n"
+ "2drop\n"
+ "endif\n"
+ "endif\n"
+ "; immediate\n"
+ ".( loading CORE EXT words ) cr\n"
+ "0 constant false\n"
+ "false invert constant true\n"
+ ": <> = 0= ;\n"
+ ": 0<> 0= 0= ;\n"
+ ": compile, , ;\n"
+ ": convert char+ 65535 >number drop ; \\ cribbed from DPANS A.6.2.0970\n"
+ ": erase ( addr u -- ) 0 fill ;\n"
+ "variable span\n"
+ ": expect ( c-addr u1 -- ) accept span ! ;\n"
+ ": nip ( y x -- x ) swap drop ;\n"
+ ": tuck ( y x -- x y x) swap over ;\n"
+ ": within ( test low high -- flag ) over - >r - r> u< ;\n"
+ ": ? ( addr -- ) @ . ;\n"
+ ": dump ( addr u -- )\n"
+ "0 ?do\n"
+ "dup c@ . 1+\n"
+ "i 7 and 7 = if cr endif\n"
+ "loop drop\n"
+ ";\n"
+ ".( loading SEARCH & SEARCH-EXT words ) cr\n"
+ ": brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;\n"
+ ": ficl-named-wordlist \\ ( hash-size name -- ) run: ( -- wid )\n"
+ "ficl-wordlist dup create , brand-wordlist does> @ ;\n"
+ ": wordlist ( -- )\n"
+ "1 ficl-wordlist ;\n"
+ ": ficl-set-current ( wid -- old-wid )\n"
+ "get-current swap set-current ;\n"
+ ": do-vocabulary ( -- )\n"
+ "does> @ search> drop >search ;\n"
+ ": ficl-vocabulary ( nBuckets name -- )\n"
+ "ficl-named-wordlist do-vocabulary ;\n"
+ ": vocabulary ( name -- )\n"
+ "1 ficl-vocabulary ;\n"
+ ": previous ( -- ) search> drop ;\n"
+ "1 ficl-named-wordlist hidden\n"
+ ": hide hidden dup >search ficl-set-current ;\n"
+ ": also ( -- )\n"
+ "search> dup >search >search ;\n"
+ ": forth ( -- )\n"
+ "search> drop\n"
+ "forth-wordlist >search ;\n"
+ ": only ( -- )\n"
+ "-1 set-order ;\n"
+ "hide\n"
+ ": list-wid ( wid -- )\n"
+ "dup wid-get-name ( wid c-addr u )\n"
+ "?dup if\n"
+ "type drop\n"
+ "else\n"
+ "drop .\" (unnamed wid) \" x.\n"
+ "endif cr\n"
+ ";\n"
+ "set-current \\ stop hiding words\n"
+ ": order ( -- )\n"
+ ".\" Search:\" cr\n"
+ "get-order 0 ?do 3 spaces list-wid loop cr\n"
+ ".\" Compile: \" get-current list-wid cr\n"
+ ";\n"
+ ": debug ' debug-xt ; immediate\n"
+ ": on-step .\" S: \" .s-simple cr ;\n"
+ "previous \\ lose hidden words from search order\n"
+ "hide\n"
+ ": ?[if] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [if]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[else] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [else]\" compare-insensitive 0=\n"
+ ";\n"
+ ": ?[then] ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" [then]\" compare-insensitive 0= >r\n"
+ "2dup s\" [endif]\" compare-insensitive 0= r>\n"
+ "or\n"
+ ";\n"
+ "set-current\n"
+ ": [else] ( -- )\n"
+ "1 \\ ( level )\n"
+ "begin\n"
+ "begin\n"
+ "parse-word dup while \\ ( level addr len )\n"
+ "?[if] if \\ ( level addr len )\n"
+ "2drop 1+ \\ ( level )\n"
+ "else \\ ( level addr len )\n"
+ "?[else] if \\ ( level addr len )\n"
+ "2drop 1- dup if 1+ endif\n"
+ "else\n"
+ "?[then] if 2drop 1- else 2drop endif\n"
+ "endif\n"
+ "endif ?dup 0= if exit endif \\ level\n"
+ "repeat 2drop \\ level\n"
+ "refill 0= until \\ level\n"
+ "drop\n"
+ "; immediate\n"
+ ": [if] ( flag -- )\n"
+ "0= if postpone [else] then ; immediate\n"
+ ": [then] ( -- ) ; immediate\n"
+ ": [endif] ( -- ) ; immediate\n"
+ "previous\n"
+ "variable save-current\n"
+ ": start-prefixes get-current save-current ! <prefixes> set-current ;\n"
+ ": end-prefixes save-current @ set-current ;\n"
+ ": show-prefixes <prefixes> >search words search> drop ;\n"
+ "start-prefixes\n"
+ "S\" FICL_WANT_EXTENDED_PREFIX\" ENVIRONMENT? drop [if]\n"
+ ": \" postpone s\" ; immediate\n"
+ ": .( postpone .( ; immediate\n"
+ ": \\ postpone \\ ; immediate\n"
+ ": // postpone \\ ; immediate\n"
+ ": 0b 2 __tempbase ; immediate\n"
+ ": 0o 8 __tempbase ; immediate\n"
+ "[endif]\n"
+ ": 0d 10 __tempbase ; immediate\n"
+ ": 0x 16 __tempbase ; immediate\n"
+ "end-prefixes\n"
+ "S\" FICL_WANT_USER\" ENVIRONMENT? drop [if]\n"
+ "variable nUser 0 nUser !\n"
+ ": user \\ name ( -- )\n"
+ "nUser dup @ user 1 swap +! ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ": locals| ( name...name | -- )\n"
+ "begin\n"
+ "bl word count\n"
+ "dup 0= abort\" where's the delimiter??\"\n"
+ "over c@\n"
+ "[char] | - over 1- or\n"
+ "while\n"
+ "(local)\n"
+ "repeat 2drop 0 0 (local)\n"
+ "; immediate\n"
+ ": local ( name -- ) bl word count (local) ; immediate\n"
+ ": 2local ( name -- ) bl word count (2local) ; immediate\n"
+ ": end-locals ( -- ) 0 0 (local) ; immediate\n"
+ ": strdup ( c-addr length -- c-addr2 length2 ior )\n"
+ "0 locals| addr2 length c-addr | end-locals\n"
+ "length 1 + allocate\n"
+ "0= if\n"
+ "to addr2\n"
+ "c-addr addr2 length move\n"
+ "addr2 length 0\n"
+ "else\n"
+ "0 -1\n"
+ "endif\n"
+ ";\n"
+ ": strcat ( 2:a 2:b -- 2:new-a )\n"
+ "0 locals| b-length b-u b-addr a-u a-addr | end-locals\n"
+ "b-u to b-length\n"
+ "b-addr a-addr a-u + b-length move\n"
+ "a-addr a-u b-length +\n"
+ ";\n"
+ ": strcpy ( 2:a 2:b -- 2:new-a )\n"
+ "locals| b-u b-addr a-u a-addr | end-locals\n"
+ "a-addr 0 b-addr b-u strcat\n"
+ ";\n"
+ "[endif]\n"
+ "S\" FICL_WANT_LOCALS\" ENVIRONMENT? drop [if]\n"
+ ".( loading Johns-Hopkins locals ) cr\n"
+ "hide\n"
+ ": compiled-zero ficlInstruction0 , ;\n"
+ ": compiled-float-zero ficlInstructionF0 , ;\n"
+ ": ?-- ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" --\" compare 0= ;\n"
+ ": ?} ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" }\" compare 0= ;\n"
+ ": ?| ( c-addr u -- c-addr u flag )\n"
+ "2dup s\" |\" compare 0= ;\n"
+ "1 constant local-is-double\n"
+ "2 constant local-is-float\n"
+ ": parse-local-prefix-flags ( c-addr u -- c-addr u flags )\n"
+ "0 0 0 locals| stop-loop colon-offset flags u c-addr |\n"
+ "c-addr c@ [char] : =\n"
+ "if\n"
+ "over over 0 exit\n"
+ "endif\n"
+ "u 0 do\n"
+ "c-addr i + c@\n"
+ "case\n"
+ "[char] 1 of flags local-is-double invert and to flags endof\n"
+ "[char] 2 of flags local-is-double or to flags endof\n"
+ "[char] d of flags local-is-double or to flags endof\n"
+ "[char] f of flags local-is-float or to flags endof\n"
+ "[char] i of flags local-is-float invert and to flags endof\n"
+ "[char] s of flags local-is-double invert and to flags endof\n"
+ "[char] : of i 1+ to colon-offset 1 to stop-loop endof\n"
+ "1 to stop-loop\n"
+ "endcase\n"
+ "stop-loop if leave endif\n"
+ "loop\n"
+ "colon-offset 0=\n"
+ "colon-offset u =\n"
+ "or\n"
+ "if\n"
+ "c-addr u 0 exit\n"
+ "endif\n"
+ "c-addr colon-offset +\n"
+ "u colon-offset -\n"
+ "flags\n"
+ ";\n"
+ ": ?delim ( c-addr u -- state | c-addr u 0 )\n"
+ "?| if 2drop 1 exit endif\n"
+ "?-- if 2drop 2 exit endif\n"
+ "?} if 2drop 3 exit endif\n"
+ "dup 0=\n"
+ "if 2drop 4 exit endif\n"
+ "0\n"
+ ";\n"
+ "set-current\n"
+ ": {\n"+ "0 0 0 locals| flags local-state nLocals |\n"
+ "begin\n"
+ "parse-word ?delim dup to local-state\n"
+ "0= while\n"
+ "nLocals 1+ to nLocals\n"
+ "repeat\n"
+ "nLocals 0 ?do\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if (f2local) else (2local) endif\n"
+ "else\n"
+ "flags local-is-float and if (flocal) else (local) endif\n"
+ "endif\n"
+ "loop \\ ( )\n"
+ "local-state 1 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "0= while\n"
+ "parse-local-prefix-flags to flags\n"
+ "flags local-is-double and if\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero compiled-float-zero (f2local)\n"
+ "else\n"
+ "compiled-zero compiled-zero (2local)\n"
+ "endif\n"
+ "else\n"
+ "flags local-is-float and if\n"
+ "compiled-float-zero (flocal)\n"
+ "else\n"
+ "compiled-zero (local)\n"
+ "endif\n"
+ "endif\n"
+ "repeat\n"
+ "endif\n"
+ "0 0 (local)\n"
+ "local-state 2 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "?delim dup to local-state\n"
+ "3 < while\n"
+ "local-state 0= if 2drop endif\n"
+ "repeat\n"
+ "endif\n"
+ "local-state 3 <> abort\" syntax error in { } local line\"\n"+ "; immediate compile-only\n"
+ "previous\n"
+ "[endif]\n"
+ ".( loading MARKER ) cr\n"
+ ": marker ( \"name\" -- )\n"
+ "create\n"
+ "get-current ,\n"
+ "get-order dup ,\n"
+ "0 ?do , loop\n"
+ "does>\n"
+ "0 set-order \\ clear search order\n"
+ "dup body> >name drop\n"
+ "here - allot \\ reset HERE to my xt-addr\n"
+ "dup @ ( pfa current-wid )\n"
+ "dup set-current forget-wid ( pfa )\n"
+ "cell+ dup @ swap ( count count-addr )\n"
+ "over cells + swap ( last-wid-addr count )\n"
+ "0 ?do\n"
+ "dup @ dup ( wid-addr wid wid )\n"
+ ">search forget-wid ( wid-addr )\n"
+ "cell-\n"
+ "loop\n"
+ "drop\n"
+ ";\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl O-O extensions ) cr\n"
+ "17 ficl-vocabulary oop\n"
+ "also oop definitions\n"
+ "user current-class\n"
+ "0 current-class !\n"
+ ": parse-method \\ name run: ( -- c-addr u )\n"
+ "parse-word\n"
+ "postpone sliteral\n"
+ "; compile-only\n"
+ ": (lookup-method) { class 2:name -- class 0 | class xt 1 | class xt -1 }\n"+ "class name class cell+ @ ( class c-addr u wid )\n"
+ "search-wordlist\n"
+ ";\n"
+ ": lookup-method { class 2:name -- class xt }\n"+ "class name (lookup-method) ( 0 | xt 1 | xt -1 )\n"
+ "0= if\n"
+ "name type .\" not found in \"\n"
+ "class body> >name type\n"
+ "cr abort\n"
+ "endif\n"
+ ";\n"
+ ": find-method-xt \\ name ( class -- class xt )\n"
+ "parse-word lookup-method\n"
+ ";\n"
+ ": catch-method ( instance class c-addr u -- <method-signature> exc-flag )\n"
+ "lookup-method catch\n"
+ ";\n"
+ ": exec-method ( instance class c-addr u -- <method-signature> )\n"
+ "lookup-method execute\n"
+ ";\n"
+ ": --> ( instance class -- ??? )\n"
+ "state @ 0= if\n"
+ "find-method-xt execute\n"
+ "else\n"
+ "parse-method postpone exec-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": c-> ( instance class -- ?? exc-flag )\n"
+ "state @ 0= if\n"
+ "find-method-xt catch\n"
+ "else\n"
+ "parse-method postpone catch-method\n"
+ "endif\n"
+ "; immediate\n"
+ ": method create does> body> >name lookup-method execute ;\n"
+ "1 ficl-named-wordlist instance-vars\n"
+ "instance-vars dup >search ficl-set-current\n"
+ ": => \\ c:( class meta -- ) run: ( -- ??? ) invokes compiled method\n"
+ "drop find-method-xt compile, drop\n"
+ "; immediate compile-only\n"
+ ": my=> \\ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class\n"
+ "current-class @ dup postpone =>\n"
+ "; immediate compile-only\n"
+ ": my=[ \\ same as my=> , but binds a chain of methods\n"
+ "current-class @\n"
+ "begin\n"
+ "parse-word 2dup ( class c-addr u c-addr u )\n"
+ "s\" ]\" compare while ( class c-addr u )\n"
+ "lookup-method ( class xt )\n"
+ "dup compile, ( class xt )\n"
+ "dup ?object if \\ If object member, get new class. Otherwise assume same class\n"
+ "nip >body cell+ @ ( new-class )\n"
+ "else\n"
+ "drop ( class )\n"
+ "endif\n"
+ "repeat 2drop drop\n"
+ "; immediate compile-only\n"
+ ": do-instance-var\n"
+ "does> ( instance class addr[offset] -- addr[field] )\n"
+ "nip @ +\n"
+ ";\n"
+ ": addr-units: ( offset size \"name\" -- offset' )\n"
+ "create over , +\n"
+ "do-instance-var\n"
+ ";\n"
+ ": chars: \\ ( offset nCells \"name\" -- offset' ) Create n char member.\n"
+ "chars addr-units: ;\n"
+ ": char: \\ ( offset nCells \"name\" -- offset' ) Create 1 char member.\n"
+ "1 chars: ;\n"
+ ": cells: ( offset nCells \"name\" -- offset' )\n"
+ "cells >r aligned r> addr-units:\n"
+ ";\n"
+ ": cell: ( offset nCells \"name\" -- offset' )\n"
+ "1 cells: ;\n"
+ ": do-aggregate\n"
+ "objectify\n"
+ "does> ( instance class pfa -- a-instance a-class )\n"
+ "2@ ( inst class a-class a-offset )\n"
+ "2swap drop ( a-class a-offset inst )\n"
+ "+ swap ( a-inst a-class )\n"
+ ";\n"
+ ": obj: { offset class meta -- offset' } \\ \"name\"\n"+ "create offset , class ,\n"
+ "class meta --> get-size offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": array: ( offset n class meta \"name\" -- offset' )\n"
+ "locals| meta class nobjs offset |\n"
+ "create offset , class ,\n"
+ "class meta --> get-size nobjs * offset +\n"
+ "do-aggregate\n"
+ ";\n"
+ ": ref: ( offset class meta \"name\" -- offset' )\n"
+ "locals| meta class offset |\n"
+ "create offset , class ,\n"
+ "offset cell+\n"
+ "does> ( inst class pfa -- ptr-inst ptr-class )\n"
+ "2@ ( inst class ptr-class ptr-offset )\n"
+ "2swap drop + @ swap\n"
+ ";\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": vcall: ( paramcnt \"name\" -- )\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall \\ ( params offset inst class offset -- )\n"
+ ";\n"
+ ": vcallr: 0x80000000 or vcall: ; \\ Call with return address desired.\n"
+ "S\" FICL_WANT_FLOAT\" ENVIRONMENT? drop [if]\n"
+ ": vcallf: \\ ( paramcnt -<name>- f: r )\n"
+ "0x80000000 or\n"
+ "current-class @ 8 + dup @ dup 1+ rot ! \\ Kludge fix to get to .vtCount before it's defined.\n"
+ "create , , \\ ( paramcnt index -- )\n"
+ "does> \\ ( inst class pfa -- ptr-inst ptr-class )\n"
+ "nip 2@ vcall f> \\ ( params offset inst class offset -- f: r )\n"
+ ";\n"
+ "[endif] \\ FICL_WANT_FLOAT\n"
+ "[endif] \\ FICL_WANT_VCALL\n"
+ ": end-class ( old-wid addr[size] size -- )\n"
+ "swap ! set-current\n"
+ "search> drop \\ pop struct builder wordlist\n"
+ ";\n"
+ ": suspend-class ( old-wid addr[size] size -- ) end-class ;\n"
+ "set-current previous\n"
+ ": do-do-instance ( -- )\n"
+ "s\" : .do-instance does> [ current-class @ ] literal ;\"\n"
+ "evaluate\n"
+ ";\n"
+ ":noname\n"
+ "wordlist\n"
+ "create\n"
+ "immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "4 cells , \\ instance size\n"
+ "[else]\n"
+ "3 cells , \\ instance size\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> dup\n"
+ "; execute metaclass\n"
+ "metaclass drop cell+ @ brand-wordlist\n"
+ "metaclass drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ "create .super ( class metaclass -- parent-class )\n"
+ "0 cells , do-instance-var\n"
+ "create .wid ( class metaclass -- wid ) \\ return wid of class\n"
+ "1 cells , do-instance-var\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ "create .vtCount \\ Number of VTABLE methods, if any\n"
+ "2 cells , do-instance-var\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "3 cells , do-instance-var\n"
+ "[else]\n"
+ "create .size ( class metaclass -- size ) \\ return class's payload size\n"
+ "2 cells , do-instance-var\n"
+ "[endif]\n"
+ ": get-size metaclass => .size @ ;\n"
+ ": get-wid metaclass => .wid @ ;\n"
+ ": get-super metaclass => .super @ ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": get-vtCount metaclass => .vtCount @ ;\n"
+ ": get-vtAdd metaclass => .vtCount ;\n"
+ "[endif]\n"
+ ": instance ( class metaclass \"name\" -- instance class )\n"
+ "locals| meta parent |\n"
+ "create\n"
+ "here parent --> .do-instance \\ ( inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "allot \\ allocate payload space\n"
+ ";\n"
+ ": array ( n class metaclass \"name\" -- n instance class )\n"
+ "locals| meta parent nobj |\n"
+ "create nobj\n"
+ "here parent --> .do-instance \\ ( nobj inst class )\n"
+ "parent meta metaclass => get-size\n"
+ "nobj * allot \\ allocate payload space\n"
+ ";\n"
+ ": new \\ ( class metaclass \"name\" -- )\n"
+ "metaclass => instance --> init\n"
+ ";\n"
+ ": new-array ( n class metaclass \"name\" -- )\n"
+ "metaclass => array\n"
+ "--> array-init\n"
+ ";\n"
+ ": alloc \\ ( class metaclass -- instance class )\n"
+ "locals| meta class |\n"
+ "class meta metaclass => get-size allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "class 2dup --> init\n"
+ ";\n"
+ ": alloc-array \\ ( n class metaclass -- instance class )\n"
+ "locals| meta class nobj |\n"
+ "class meta metaclass => get-size\n"
+ "nobj * allocate ( -- addr fail-flag )\n"
+ "abort\" allocate failed \" ( -- addr )\n"
+ "nobj over class --> array-init\n"
+ "class\n"
+ ";\n"
+ ": allot { 2:this -- 2:instance }\n"+ "here ( instance-address )\n"
+ "this my=> get-size allot\n"
+ "this drop 2dup --> init\n"
+ ";\n"
+ ": allot-array { nobj 2:this -- 2:instance }\n"+ "here ( instance-address )\n"
+ "this my=> get-size nobj * allot\n"
+ "this drop 2dup ( 2instance 2instance )\n"
+ "nobj -rot --> array-init\n"
+ ";\n"
+ ": ref ( instance-addr class metaclass \"name\" -- )\n"
+ "drop create , ,\n"
+ "does> 2@\n"
+ ";\n"
+ ": resume-class { 2:this -- old-wid addr[size] size }\n"+ "this --> .wid @ ficl-set-current ( old-wid )\n"
+ "this --> .size dup @ ( old-wid addr[size] size )\n"
+ "instance-vars >search\n"
+ ";\n"
+ ": sub ( class metaclass \"name\" -- old-wid addr[size] size )\n"
+ "wordlist\n"
+ "locals| wid meta parent |\n"
+ "parent meta metaclass => get-wid\n"
+ "wid wid-set-super \\ set superclass\n"
+ "create immediate \\ get the subclass name\n"
+ "wid brand-wordlist \\ label the subclass wordlist\n"
+ "here current-class ! \\ prep for do-do-instance\n"
+ "parent , \\ save parent class\n"
+ "wid , \\ save wid\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "parent meta --> get-vtCount ,\n"
+ "[endif]\n"
+ "here parent meta --> get-size dup , ( addr[size] size )\n"
+ "metaclass => .do-instance\n"
+ "wid ficl-set-current -rot\n"
+ "do-do-instance\n"
+ "instance-vars >search \\ push struct builder wordlist\n"
+ ";\n"
+ ": offset-of ( class metaclass \"name\" -- offset )\n"
+ "drop find-method-xt nip >body @ ;\n"
+ ": id ( class metaclass -- c-addr u )\n"
+ "drop body> >name ;\n"
+ ": methods \\ ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type .\" methods:\" cr\n"
+ "class meta --> get-wid >search words cr previous\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": pedigree ( class meta -- )\n"
+ "locals| meta class |\n"
+ "begin\n"
+ "class body> >name type space\n"
+ "class meta metaclass => get-super\n"
+ "dup to class\n"
+ "0= until cr\n"
+ ";\n"
+ ": see ( class meta -- )\n"
+ "metaclass => get-wid >search see previous ;\n"
+ ": debug ( class meta -- )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "metaclass drop\n"
+ "constant meta\n"
+ ": subclass --> sub ;\n"
+ "S\" FICL_WANT_VCALL\" ENVIRONMENT? drop [if]\n"
+ ": hasvtable 4 + ; immediate\n"
+ "[endif]\n"
+ ":noname\n"
+ "wordlist\n"
+ "create immediate\n"
+ "0 , \\ NULL parent class\n"
+ "dup , \\ wid\n"
+ "0 , \\ instance size\n"
+ "[ S\" FICL_WANT_VCALL\" ENVIRONMENT? drop ] [if]\n"
+ "0 , \\ .vtCount\n"
+ "[endif]\n"
+ "ficl-set-current\n"
+ "does> meta\n"
+ "; execute object\n"
+ "object drop cell+ @ brand-wordlist\n"
+ "object drop current-class !\n"
+ "do-do-instance\n"
+ "instance-vars >search\n"
+ ": class ( instance class -- class metaclass )\n"
+ "nip meta ;\n"
+ ": init ( instance class -- )\n"
+ "meta\n"
+ "metaclass => get-size ( inst size )\n"
+ "erase ;\n"
+ ": array-init ( nobj inst class -- )\n"
+ "0 dup locals| &init &next class inst |\n"
+ "class s\" init\" lookup-method to &init\n"
+ "s\" next\" lookup-method to &next\n"
+ "drop\n"
+ "0 ?do\n"
+ "inst class 2dup\n"
+ "&init execute\n"
+ "&next execute drop to inst\n"
+ "loop\n"
+ ";\n"
+ ": free \\ ( instance class -- )\n"
+ "drop free\n"
+ "abort\" free failed \"\n"
+ ";\n"
+ ": super ( instance class -- instance parent-class )\n"
+ "meta metaclass => get-super ;\n"
+ ": pedigree ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => pedigree ;\n"
+ ": size ( instance class -- sizeof-instance )\n"
+ "object => class\n"
+ "metaclass => get-size ;\n"
+ ": methods ( instance class -- )\n"
+ "object => class\n"
+ "metaclass => methods ;\n"
+ ": index ( n instance class -- instance[n] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size * ( n*size )\n"
+ "inst + class ;\n"
+ ": next ( instance[n] class -- instance[n+1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst +\n"
+ "class ;\n"
+ ": prev ( instance[n] class -- instance[n-1] class )\n"
+ "locals| class inst |\n"
+ "inst class\n"
+ "object => class\n"
+ "metaclass => get-size\n"
+ "inst swap -\n"
+ "class ;\n"
+ ": debug ( 2this -- ?? )\n"
+ "find-method-xt debug-xt ;\n"
+ "previous set-current\n"
+ "only definitions\n"
+ ": oo only also oop definitions ;\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl utility classes ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-ref\n"
+ "cell: .class\n"
+ "cell: .instance\n"
+ ": get ( inst class -- refinst refclass )\n"
+ "drop 2@ ;\n"
+ ": set ( refinst refclass inst class -- )\n"
+ "drop 2! ;\n"
+ "end-class\n"
+ "object subclass c-byte\n"
+ "char: .payload\n"
+ ": get drop c@ ;\n"
+ ": set drop c! ;\n"
+ "end-class\n"
+ "object subclass c-2byte\n"
+ "2 chars: .payload\n"
+ ": get drop w@ ;\n"
+ ": set drop w! ;\n"
+ "end-class\n"
+ "object subclass c-4byte\n"
+ "4 chars: .payload\n"
+ ": get drop q@ ;\n"
+ ": set drop q! ;\n"
+ "end-class\n"
+ "object subclass c-cell\n"
+ "cell: .payload\n"
+ ": get drop @ ;\n"
+ ": set drop ! ;\n"
+ "end-class\n"
+ "object subclass c-ptr\n"
+ "c-cell obj: .addr\n"
+ ": get-ptr ( inst class -- addr )\n"
+ "c-ptr => .addr\n"
+ "c-cell => get\n"
+ ";\n"
+ ": set-ptr ( addr inst class -- )\n"
+ "c-ptr => .addr\n"
+ "c-cell => set\n"
+ ";\n"
+ ": clr-ptr\n"
+ "0 -rot c-ptr => .addr c-cell => set\n"
+ ";\n"
+ ": ?null ( inst class -- flag )\n"
+ "c-ptr => get-ptr 0=\n"
+ ";\n"
+ ": inc-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size + -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": dec-ptr ( inst class -- )\n"
+ "2dup 2dup ( i c i c i c )\n"
+ "c-ptr => get-ptr -rot ( i c addr i c )\n"
+ "--> @size - -rot ( addr' i c )\n"
+ "c-ptr => set-ptr\n"
+ ";\n"
+ ": index-ptr { index 2:this -- }\n"+ "this --> get-ptr ( addr )\n"
+ "this --> @size index * + ( addr' )\n"
+ "this --> set-ptr\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-cellPtr\n"
+ ": @size 2drop 1 cells ;\n"
+ ": get ( inst class -- cell )\n"
+ "c-ptr => get-ptr @\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr !\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-4bytePtr\n"
+ ": @size 2drop 4 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr q@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr q!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-2bytePtr\n"
+ ": @size 2drop 2 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr w@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr w!\n"
+ ";\n"
+ "end-class\n"
+ "c-ptr subclass c-bytePtr\n"
+ ": @size 2drop 1 ;\n"
+ ": get ( inst class -- value )\n"
+ "c-ptr => get-ptr c@\n"
+ ";\n"
+ ": set ( value inst class -- )\n"
+ "c-ptr => get-ptr c!\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_WANT_OOP\" ENVIRONMENT? drop [if]\n"
+ ".( loading ficl string class ) cr\n"
+ "also oop definitions\n"
+ "object subclass c-string\n"
+ "c-cell obj: .count\n"
+ "c-cell obj: .buflen\n"
+ "c-ptr obj: .buf\n"
+ "32 constant min-buf\n"
+ ": get-count ( 2:this -- count ) my=[ .count get ] ;\n"
+ ": set-count ( count 2:this -- ) my=[ .count set ] ;\n"
+ ": ?empty ( 2:this -- flag ) --> get-count 0= ;\n"
+ ": get-buflen ( 2:this -- len ) my=[ .buflen get ] ;\n"
+ ": set-buflen ( len 2:this -- ) my=[ .buflen set ] ;\n"
+ ": get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;\n"
+ ": set-buf { ptr len 2:this -- }\n"+ "ptr this my=[ .buf set-ptr ]\n"
+ "len this my=> set-buflen\n"
+ ";\n"
+ ": clr-buf ( 2:this -- )\n"
+ "0 0 2over my=> set-buf\n"
+ "0 -rot my=> set-count\n"
+ ";\n"
+ ": free-buf { 2:this -- }\n"+ "this my=> get-buf\n"
+ "?dup if\n"
+ "free\n"
+ "abort\" c-string free failed\"\n"
+ "this my=> clr-buf\n"
+ "endif\n"
+ ";\n"
+ ": size-buf { size 2:this -- }\n"+ "size 0< abort\" need positive size for size-buf\"\n"
+ "size 0= if\n"
+ "this --> free-buf exit\n"
+ "endif\n"
+ "my=> min-buf size over / 1+ * chars to size\n"
+ "this --> get-buflen 0=\n"
+ "if\n"
+ "size allocate\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "size this --> set-buflen\n"
+ "exit\n"
+ "endif\n"
+ "size this --> get-buflen > if\n"
+ "this --> get-buf size resize\n"
+ "abort\" out of memory\"\n"
+ "size this --> set-buf\n"
+ "endif\n"
+ ";\n"
+ ": set { c-addr u 2:this -- }\n"+ "u this --> size-buf\n"
+ "u this --> set-count\n"
+ "c-addr this --> get-buf u move\n"
+ ";\n"
+ ": get { 2:this -- c-addr u }\n"+ "this --> get-buf\n"
+ "this --> get-count\n"
+ ";\n"
+ ": cat { c-addr u 2:this -- }\n"+ "this --> get-count u + dup >r\n"
+ "this --> size-buf\n"
+ "c-addr this --> get-buf this --> get-count + u move\n"
+ "r> this --> set-count\n"
+ ";\n"
+ ": type { 2:this -- }\n"+ "this --> ?empty if .\" (empty) \" exit endif\n"
+ "this --> .buf --> get-ptr\n"
+ "this --> .count --> get\n"
+ "type\n"
+ ";\n"
+ ": compare ( 2string 2:this -- n )\n"
+ "--> get\n"
+ "2swap\n"
+ "--> get\n"
+ "2swap compare\n"
+ ";\n"
+ ": hashcode ( 2:this -- hashcode )\n"
+ "--> get hash\n"
+ ";\n"
+ ": free ( 2:this -- ) 2dup --> free-buf object => free ;\n"
+ "end-class\n"
+ "c-string subclass c-hashstring\n"
+ "c-2byte obj: .hashcode\n"
+ ": set-hashcode { 2:this -- }\n"+ "this --> super --> hashcode\n"
+ "this --> .hashcode --> set\n"
+ ";\n"
+ ": get-hashcode ( 2:this -- hashcode )\n"
+ "--> .hashcode --> get\n"
+ ";\n"
+ ": set ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> set\n"
+ "--> set-hashcode\n"
+ ";\n"
+ ": cat ( c-addr u 2:this -- )\n"
+ "2swap 2over --> super --> cat\n"
+ "--> set-hashcode\n"
+ ";\n"
+ "end-class\n"
+ "previous definitions\n"
+ "[endif]\n"
+ "S\" FICL_PLATFORM_OS\" ENVIRONMENT? drop S\" WIN32\" compare-insensitive 0= [if]\n"
+ ": GetProcAddress ( name-addr name-u hmodule -- address )\n"
+ "3 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "2 \\ cstringArgumentBitfield\n"
+ "(get-proc-address) \\ functionAddress\n"
+ "[\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": LoadLibrary ( name-addr name-u -- hmodule )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" LoadLibraryA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": FreeLibrary ( hmodule -- success )\n"
+ "1 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" FreeLibrary\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": DebugBreak ( -- )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" DebugBreak\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": OutputDebugString ( addr u -- )\n"
+ "2 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "1 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" OutputDebugStringA\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-void or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ ": GetTickCount ( -- ticks )\n"
+ "0 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "[\n"
+ "S\" GetTickCount\" kernel32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "S\" user32.dll\" LoadLibrary constant user32.dll\n"
+ ": MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )\n"
+ "6 \\ argumentCount\n"
+ "0 \\ floatArgumentBitfield\n"
+ "[\n"
+ "2 8 or literal \\ cstringArgumentBitfield\n"
+ "S\" MessageBoxA\" user32.dll GetProcAddress literal \\ functionAddress\n"
+ "multicall-calltype-function multicall-returntype-integer or literal \\ flags\n"
+ "]\n"
+ "multicall ;\n"
+ "0x00000000 constant MB_OK\n"
+ "0x00000001 constant MB_OKCANCEL\n"
+ "0x00000002 constant MB_ABORTRETRYIGNORE\n"
+ "0x00000003 constant MB_YESNOCANCEL\n"
+ "0x00000004 constant MB_YESNO\n"
+ "0x00000005 constant MB_RETRYCANCEL\n"
+ "0x00000010 constant MB_ICONHAND\n"
+ "0x00000020 constant MB_ICONQUESTION\n"
+ "0x00000030 constant MB_ICONEXCLAMATION\n"
+ "0x00000040 constant MB_ICONASTERISK\n"
+ "0x00000080 constant MB_USERICON\n"
+ "0x00000000 constant MB_DEFBUTTON1\n"
+ "0x00000100 constant MB_DEFBUTTON2\n"
+ "0x00000200 constant MB_DEFBUTTON3\n"
+ "0x00000300 constant MB_DEFBUTTON4\n"
+ "0x00000000 constant MB_APPLMODAL\n"
+ "0x00001000 constant MB_SYSTEMMODAL\n"
+ "0x00002000 constant MB_TASKMODAL\n"
+ "0x00004000 constant MB_HELP\n"
+ "0x00008000 constant MB_NOFOCUS\n"
+ "0x00010000 constant MB_SETFOREGROUND\n"
+ "0x00020000 constant MB_DEFAULT_DESKTOP_ONLY\n"
+ "0x00040000 constant MB_TOPMOST\n"
+ "0x00080000 constant MB_RIGHT\n"
+ "0x00100000 constant MB_RTLREADING\n"
+ "MB_ICONEXCLAMATION constant MB_ICONWARNING\n"
+ "MB_ICONHAND constant MB_ICONERROR\n"
+ "MB_ICONASTERISK constant MB_ICONINFORMATION\n"
+ "MB_ICONHAND constant MB_ICONSTOP\n"
+ "0x00200000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION\n"
+ "0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X\n"
+ "0x0000000F constant MB_TYPEMASK\n"
+ "0x000000F0 constant MB_ICONMASK\n"
+ "0x00000F00 constant MB_DEFMASK\n"
+ "0x00003000 constant MB_MODEMASK\n"
+ "0x0000C000 constant MB_MISCMASK\n"
+ "1 constant IDOK\n"
+ "2 constant IDCANCEL\n"
+ "3 constant IDABORT\n"
+ "4 constant IDRETRY\n"
+ "5 constant IDIGNORE\n"
+ "6 constant IDYES\n"
+ "7 constant IDNO\n"
+ "8 constant IDCLOSE\n"
+ "9 constant IDHELP\n"
+ ": output-debug-string OutputDebugString ;\n"
+ ": debug-break DebugBreak ;\n"
+ ": uaddr->cstring { addr u | cstring -- cstring }\n"+ "u 1+ allocate\n"
+ "0= if\n"
+ "to cstring\n"
+ "addr cstring u move\n"
+ "0 cstring u + c!\n"
+ "cstring\n"
+ "else\n"
+ "0\n"
+ "endif\n"
+ ";\n"
+ ": callnativeFunction { functionAddress popStack -- }\n"+ "0 \\ floatArgumentBitfield\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "functionAddress \\ functionAddress\n"
+ "[\n"
+ "multicall-calltype-function\n"
+ "multicall-returntype-integer or\n"
+ "multicall-reverse-arguments or\n"
+ "literal\n"
+ "]\n"
+ "multicall\n"
+ ";\n"
+ ": callcfunction 1 callnativeFunction ;\n"
+ ": callpascalfunction 0 callnativeFunction ;\n"
+ ": vcall { argumentCount index -- }\n"+ "argumentCount 0x80000000 invert or \\ cleaned-up argumentCount\n"
+ "0 \\ cstringArgumentBitfield\n"
+ "0 \\ cstringFlags\n"
+ "index \\ index\n"
+ "argumentCount 0x80000000 and if multicall-returntype-integer else multicall-returntype-void endif\n"
+ "[\n"
+ "multicall-calltype-virtual-method\n"
+ "multicall-reverse-arguments or\n"
+ "literal\n"
+ "] or\n"
+ "multicall\n"
+ ";\n"
+ "[endif]\n"
+ "hide\n"
+ "0 constant zero\n"
+ ": ?-- s\" --\" compare 0= ;\n"
+ ": ?}} s\" }}\" compare 0= ;\n"
+ "set-current\n"
+ ": {{\n"+ "0 dup locals| nLocs locstate |\n"
+ "begin\n"
+ "parse-word\n"
+ "?dup 0= abort\" Error: out of text without seeing }}\"\n"
+ "2dup 2dup ?-- -rot ?}} or 0=\n"
+ "while\n"
+ "nLocs 1+ to nLocs\n"
+ "repeat\n"
+ "?-- if 1 to locstate endif\n"
+ "nLocs 0 do\n"
+ "(local)\n"
+ "loop\n"
+ "locstate 1 = if\n"
+ "begin\n"
+ "parse-word\n"
+ "2dup ?}} 0=\n"
+ "while\n"
+ "postpone zero (local)\n"
+ "repeat\n"
+ "2drop\n"
+ "endif\n"
+ "0 0 (local)\n"
+ "; immediate compile-only\n"
+ "previous\n"
+ "S\" FICL_WANT_FILE\" ENVIRONMENT? drop [if]\n"
+ ": r/o 1 ;\n"
+ ": r/w 3 ;\n"
+ ": w/o 2 ;\n"
+ ": bin 8 or ;\n"
+ ": included\n"
+ "r/o bin open-file 0= if\n"
+ "include-file\n"
+ "else\n"
+ "drop\n"
+ "endif\n"
+ ";\n"
+ ": include parse-word included ;\n"
+ "[endif]\n"
+;
+
+#else /* !FICL_WANT_LZ_SOFTCORE */
+
+static unsigned char ficlSoftcoreCompressed[11490] = {+ 0xfe, 0x00, 0x01, 0x66, 0xcd, 0xfd, 0x64, 0x57,
+ 0x1d, 0x08, 0x0c, 0xa6, 0xd3, 0x81, 0xd0, 0xf2,
+ 0x20, 0x14, 0x08, 0x0f, 0x06, 0xe1, 0x70, 0xb8,
+ 0xf0, 0x31, 0x10, 0x0b, 0x45, 0xa2, 0x01, 0x48,
+ 0x80, 0xc8, 0x65, 0x80, 0x20, 0x1a, 0x04, 0x03,
+ 0x01, 0x00, 0xfc, 0xc8, 0x6f, 0x80, 0xa8, 0x1c,
+ 0x8d, 0xe7, 0x01, 0x01, 0xb0, 0xdf, 0x02, 0x40,
+ 0x9d, 0x82, 0xa0, 0x00, 0x06, 0x33, 0x29, 0xb0,
+ 0xd9, 0x01, 0x20, 0x14, 0x08, 0x0c, 0x26, 0x48,
+ 0x11, 0x00, 0x82, 0x02, 0x21, 0x61, 0x81, 0xc8,
+ 0x8a, 0x44, 0x05, 0xb1, 0x04, 0x03, 0xc0, 0xc7,
+ 0x03, 0x10, 0xb9, 0x88, 0x0b, 0xb0, 0x26, 0x03,
+ 0x49, 0xd0, 0xca, 0x72, 0x30, 0x9b, 0x20, 0x20,
+ 0x02, 0x08, 0x16, 0x08, 0xb6, 0x04, 0x60, 0x74,
+ 0x81, 0xa8, 0x88, 0x0c, 0x50, 0x2f, 0x01, 0x04,
+ 0x04, 0x42, 0xc7, 0x06, 0x71, 0x94, 0x88, 0x06,
+ 0x50, 0x60, 0x13, 0x64, 0x16, 0x40, 0x77, 0x02,
+ 0xd0, 0xb0, 0x98, 0xa0, 0x9e, 0x02, 0x88, 0x04,
+ 0x80, 0x82, 0x02, 0x21, 0x78, 0x80, 0x98, 0x02,
+ 0x8c, 0x87, 0x58, 0x12, 0x80, 0xc0, 0x78, 0x20,
+ 0x34, 0x99, 0x84, 0x06, 0xe3, 0x29, 0x9c, 0xc3,
+ 0x05, 0x50, 0x10, 0x19, 0x4d, 0xc6, 0x48, 0x4d,
+ 0x84, 0xee, 0x12, 0x60, 0x65, 0x31, 0x9a, 0x4d,
+ 0xb0, 0x58, 0x09, 0x9c, 0x1e, 0x40, 0xc6, 0x6f,
+ 0x37, 0x1c, 0xce, 0x86, 0x13, 0x74, 0x19, 0x00,
+ 0xc4, 0x6c, 0x81, 0x68, 0x5c, 0xce, 0x06, 0x18,
+ 0x18, 0x00, 0x82, 0x01, 0x00, 0x2d, 0x80, 0x90,
+ 0x98, 0xa0, 0xb2, 0x06, 0x53, 0x6c, 0x15, 0x00,
+ 0x41, 0x02, 0xc1, 0x39, 0xc3, 0x1c, 0x4e, 0x70,
+ 0x07, 0x0b, 0x74, 0x04, 0x08, 0x61, 0x01, 0xd1,
+ 0xb9, 0xc3, 0x1c, 0x6d, 0x90, 0x28, 0x33, 0x09,
+ 0x88, 0xde, 0x72, 0x3a, 0x08, 0x81, 0x50, 0xbb,
+ 0x0b, 0xa4, 0x28, 0xc0, 0x81, 0x09, 0xa0, 0x85,
+ 0x1c, 0x0d, 0xf0, 0xbb, 0x03, 0x84, 0x2e, 0x40,
+ 0xcb, 0x11, 0x25, 0x10, 0x0b, 0xa2, 0x12, 0x07,
+ 0x08, 0x8b, 0x99, 0x8c, 0xe4, 0x0a, 0x16, 0x8c,
+ 0xa2, 0x2a, 0x86, 0xc8, 0x2a, 0x10, 0x2a, 0x22,
+ 0xc7, 0x74, 0x34, 0x40, 0x8c, 0x0e, 0xf1, 0x15,
+ 0x43, 0x2c, 0x29, 0x84, 0x15, 0x03, 0x10, 0x39,
+ 0x99, 0x41, 0x45, 0xb3, 0x19, 0xa0, 0xc2, 0x72,
+ 0x82, 0x88, 0x08, 0x84, 0x10, 0xc7, 0x03, 0x94,
+ 0x5b, 0x82, 0xe5, 0x06, 0x30, 0xb4, 0xc4, 0x50,
+ 0x0e, 0x87, 0x93, 0x84, 0x5b, 0xc0, 0xc7, 0x13,
+ 0x81, 0x10, 0x45, 0x5c, 0x8c, 0xb1, 0x6d, 0x11,
+ 0x94, 0x08, 0x84, 0x15, 0x16, 0x62, 0xb7, 0x45,
+ 0xa0, 0x47, 0x70, 0x9a, 0x03, 0x69, 0xb4, 0xcb,
+ 0x0a, 0x70, 0x30, 0xc1, 0x54, 0x01, 0x42, 0xe8,
+ 0x04, 0x01, 0xb0, 0xdf, 0x03, 0x80, 0x34, 0x9b,
+ 0x8c, 0xe2, 0x02, 0x19, 0x3c, 0xa4, 0x45, 0x10,
+ 0x11, 0x4b, 0x05, 0x41, 0x01, 0xde, 0x20, 0xc0,
+ 0x64, 0x82, 0x78, 0x0a, 0x62, 0x6c, 0x23, 0x08,
+ 0x5b, 0xa1, 0x9a, 0x0b, 0x00, 0x73, 0x8b, 0x78,
+ 0x19, 0xa3, 0xcc, 0x22, 0x08, 0xe1, 0x01, 0xda,
+ 0x0a, 0xc0, 0x74, 0x85, 0xba, 0x1d, 0x0e, 0x47,
+ 0x58, 0xb7, 0x80, 0xe8, 0x40, 0x3c, 0x1f, 0x08,
+ 0x07, 0xb0, 0x1b, 0x01, 0xec, 0x0a, 0xc6, 0x61,
+ 0x20, 0x80, 0x98, 0x48, 0x2c, 0xec, 0x66, 0xf8,
+ 0x01, 0x81, 0xa4, 0xd8, 0x65, 0x16, 0x08, 0x24,
+ 0x52, 0x03, 0xb9, 0x0f, 0x8d, 0xba, 0x3e, 0x64,
+ 0x68, 0x8b, 0xa0, 0x0a, 0xc4, 0x03, 0x61, 0xa8,
+ 0xd4, 0x66, 0x35, 0x10, 0x0f, 0x8d, 0xc7, 0x53,
+ 0x69, 0x8a, 0x0a, 0xc0, 0x20, 0x81, 0x10, 0xce,
+ 0xc4, 0x05, 0xc8, 0x9b, 0x05, 0xa4, 0xc5, 0x24,
+ 0x90, 0x32, 0x47, 0x90, 0x0e, 0x52, 0x23, 0x01,
+ 0x01, 0x10, 0xa0, 0x41, 0x27, 0x14, 0xc4, 0x04,
+ 0x11, 0x70, 0xd8, 0x5c, 0x32, 0x17, 0x0c, 0x07,
+ 0x23, 0x71, 0x84, 0x0b, 0x42, 0xcb, 0x05, 0x70,
+ 0x39, 0xc3, 0x28, 0x4c, 0x30, 0x39, 0x13, 0xac,
+ 0x3a, 0x4c, 0xcd, 0x22, 0x60, 0x36, 0x40, 0xac,
+ 0x2e, 0xd1, 0x74, 0x03, 0x4c, 0x21, 0x40, 0xd9,
+ 0x0a, 0x30, 0x39, 0xc3, 0x1c, 0x0d, 0xd2, 0x73,
+ 0x13, 0xc4, 0x62, 0x40, 0xc7, 0x06, 0x41, 0x31,
+ 0x8b, 0x64, 0xfc, 0x43, 0x18, 0x08, 0x11, 0x84,
+ 0xc7, 0x03, 0x00, 0x38, 0x41, 0x90, 0x0e, 0x72,
+ 0x9d, 0x09, 0x00, 0x86, 0x05, 0x63, 0x6e, 0x34,
+ 0xc0, 0x94, 0x05, 0x02, 0x08, 0x03, 0x01, 0xe2,
+ 0x11, 0x85, 0x20, 0x39, 0x9d, 0xcc, 0x30, 0x25,
+ 0x03, 0x24, 0x93, 0x86, 0x15, 0x00, 0x00, 0x3a,
+ 0x1d, 0x4c, 0x66, 0xb9, 0x68, 0x29, 0xe6, 0x01,
+ 0x20, 0x29, 0x96, 0xe9, 0x1b, 0xe3, 0xe6, 0x12,
+ 0x08, 0x16, 0x09, 0xde, 0x0a, 0x80, 0x68, 0x8e,
+ 0x10, 0x08, 0x20, 0x10, 0x07, 0x48, 0x71, 0x81,
+ 0xd2, 0x04, 0xc1, 0x77, 0x10, 0x4c, 0x48, 0x0c,
+ 0xf0, 0x1a, 0x01, 0x6c, 0x04, 0x80, 0xcc, 0x6c,
+ 0x30, 0xc7, 0x10, 0x05, 0x33, 0x05, 0x21, 0x6c,
+ 0x91, 0x00, 0xe5, 0x05, 0xa0, 0xb9, 0x48, 0x24,
+ 0x0e, 0xb0, 0x99, 0x01, 0xdc, 0x0b, 0x42, 0x7f,
+ 0x03, 0x54, 0x94, 0xc4, 0x40, 0x25, 0xd0, 0x2b,
+ 0x1b, 0x24, 0x91, 0xc0, 0xe1, 0x27, 0xb6, 0x05,
+ 0x40, 0x70, 0x61, 0x50, 0x94, 0x13, 0x1c, 0xd5,
+ 0x04, 0x62, 0x2b, 0x05, 0x1a, 0x44, 0x03, 0x78,
+ 0x1b, 0x81, 0xba, 0x4b, 0x80, 0x37, 0x90, 0x50,
+ 0x5a, 0x61, 0x38, 0x06, 0x38, 0x1d, 0x81, 0x96,
+ 0x2c, 0xe3, 0x6c, 0x81, 0x40, 0x99, 0x23, 0x3e,
+ 0x23, 0xb8, 0xdd, 0x29, 0x4c, 0x8a, 0x41, 0x29,
+ 0x10, 0xc9, 0x02, 0x01, 0x34, 0xeb, 0xca, 0x5b,
+ 0x1c, 0xb6, 0x9d, 0x41, 0xa4, 0x0e, 0x53, 0x85,
+ 0x09, 0x6c, 0x73, 0xc4, 0xd8, 0x69, 0x98, 0xd0,
+ 0x4a, 0x26, 0x1c, 0x16, 0x48, 0x08, 0x11, 0xb2,
+ 0x4f, 0x00, 0x74, 0x9e, 0xb0, 0xc8, 0x24, 0x8a,
+ 0x06, 0x18, 0xd9, 0x80, 0x82, 0x04, 0x43, 0x77,
+ 0x9f, 0x18, 0x0b, 0x62, 0xdc, 0x07, 0x41, 0x6c,
+ 0xfd, 0x86, 0x77, 0x02, 0xd0, 0xb3, 0x1a, 0x4c,
+ 0x70, 0x33, 0x03, 0x74, 0xfd, 0xc2, 0xc9, 0x3d,
+ 0x64, 0x2e, 0x40, 0x1c, 0x2d, 0x12, 0x78, 0x03,
+ 0x45, 0x00, 0xc0, 0xd2, 0x7a, 0x85, 0x18, 0x1b,
+ 0xa7, 0xee, 0x22, 0xd8, 0x09, 0x09, 0xc8, 0xea,
+ 0x6e, 0x80, 0x00, 0x0a, 0x20, 0x20, 0x27, 0x79,
+ 0xf1, 0x84, 0xa6, 0x3d, 0x40, 0x69, 0xa0, 0x98,
+ 0x5d, 0xe7, 0xb0, 0x66, 0x49, 0xbb, 0x09, 0xc8,
+ 0xcb, 0x0a, 0x11, 0x16, 0x4f, 0x41, 0xcc, 0x86,
+ 0xf8, 0x71, 0x80, 0xfa, 0x22, 0x01, 0x3b, 0x98,
+ 0x60, 0x9b, 0xe7, 0xb2, 0x72, 0xd9, 0xb5, 0x88,
+ 0xc6, 0x82, 0x04, 0x77, 0x9e, 0xc1, 0x8e, 0xe8,
+ 0x1c, 0x67, 0x3a, 0x02, 0x85, 0x8c, 0xea, 0x72,
+ 0xa3, 0x00, 0x1b, 0xa7, 0xbc, 0x96, 0xf3, 0x64,
+ 0xf5, 0x42, 0xd3, 0x44, 0x91, 0x33, 0xd2, 0xb5,
+ 0x2e, 0x72, 0xdf, 0x13, 0x9d, 0x2b, 0x52, 0x77,
+ 0x35, 0x91, 0x37, 0x8b, 0x4e, 0xc6, 0xf3, 0x1c,
+ 0x21, 0x40, 0xeb, 0x32, 0xa0, 0x39, 0x40, 0x18,
+ 0x45, 0xb3, 0x6b, 0x13, 0x25, 0x1e, 0x0a, 0xe7,
+ 0x46, 0x10, 0x39, 0x45, 0xc8, 0x07, 0xd0, 0x21,
+ 0x21, 0xf5, 0x42, 0x48, 0x41, 0x40, 0xd3, 0xbb,
+ 0x53, 0xc1, 0x4d, 0xc4, 0x29, 0x76, 0x85, 0x94,
+ 0xe9, 0x04, 0xf0, 0x37, 0x50, 0xd0, 0xc1, 0x54,
+ 0x11, 0x93, 0x25, 0x3b, 0x56, 0x77, 0x02, 0xd0,
+ 0xbb, 0x54, 0xa1, 0x6c, 0x35, 0x3f, 0x31, 0x8d,
+ 0x48, 0x5e, 0x77, 0x02, 0xd0, 0xb8, 0x51, 0x80,
+ 0x0e, 0xc6, 0x93, 0x79, 0xd6, 0x10, 0xe2, 0x2d,
+ 0x80, 0x90, 0x9c, 0xea, 0x14, 0xa3, 0xba, 0x49,
+ 0x19, 0xba, 0x82, 0xec, 0x68, 0x9f, 0x18, 0x19,
+ 0x21, 0x4a, 0x00, 0xa8, 0x00, 0x01, 0xa2, 0x7c,
+ 0x60, 0x65, 0xae, 0x71, 0x48, 0x21, 0x28, 0x23,
+ 0xea, 0x8b, 0x95, 0x9a, 0x95, 0x0e, 0x3b, 0x84,
+ 0x10, 0x9b, 0x0e, 0x70, 0x20, 0x01, 0x44, 0xda,
+ 0x48, 0xe7, 0x50, 0xa3, 0x3a, 0xd4, 0x51, 0x07,
+ 0xd5, 0x17, 0x53, 0x7c, 0x41, 0xc0, 0xd1, 0x60,
+ 0x97, 0xb9, 0x46, 0x80, 0x2c, 0xd6, 0x32, 0x11,
+ 0x6c, 0xf5, 0xce, 0x7d, 0x51, 0x74, 0xb7, 0x9b,
+ 0x8d, 0x94, 0xf8, 0x39, 0x6c, 0x03, 0xc0, 0xe7,
+ 0x40, 0x50, 0xb7, 0xc7, 0x44, 0x0c, 0xb3, 0x09,
+ 0x13, 0x45, 0x76, 0x42, 0x15, 0x00, 0x00, 0x36,
+ 0x4f, 0x70, 0x25, 0xb3, 0xe2, 0x11, 0x44, 0xf8,
+ 0x4e, 0x15, 0x09, 0x41, 0x3b, 0xd0, 0x04, 0x2c,
+ 0xf4, 0x05, 0x31, 0x44, 0xf8, 0x46, 0xc7, 0x2a,
+ 0xd2, 0x90, 0x42, 0x48, 0x07, 0xf0, 0x94, 0x13,
+ 0x4c, 0x61, 0x48, 0x41, 0x19, 0xe2, 0x36, 0x45,
+ 0xb8, 0x2c, 0x90, 0x23, 0x11, 0x74, 0x5e, 0x00,
+ 0x51, 0x43, 0xe0, 0x37, 0x50, 0x5c, 0x44, 0x13,
+ 0xe2, 0x09, 0x4c, 0x5d, 0xc2, 0xf0, 0x2e, 0x8d,
+ 0x11, 0x08, 0x22, 0x6e, 0x13, 0xbb, 0x08, 0x05,
+ 0xd2, 0x95, 0xe7, 0x5c, 0x86, 0x28, 0x1d, 0x20,
+ 0x48, 0x16, 0x89, 0xf1, 0x81, 0xa6, 0x38, 0x61,
+ 0x77, 0x8e, 0x80, 0x82, 0xac, 0xc8, 0x17, 0x2b,
+ 0x3d, 0x88, 0xa2, 0x6d, 0x24, 0x2e, 0x8b, 0xc0,
+ 0x14, 0xea, 0x14, 0x33, 0xa8, 0xbc, 0x01, 0x8e,
+ 0x27, 0x00, 0x67, 0xb3, 0xb1, 0xcc, 0x20, 0x3a,
+ 0x33, 0x38, 0x6f, 0x19, 0xb2, 0xd1, 0x26, 0x6c,
+ 0x81, 0x40, 0x98, 0xe2, 0x70, 0x02, 0xe8, 0xbc,
+ 0x01, 0x0e, 0x44, 0x64, 0x3a, 0x8b, 0xb8, 0x59,
+ 0xe9, 0x5a, 0x96, 0xcb, 0x44, 0x99, 0x8e, 0xde,
+ 0xe2, 0x3a, 0x80, 0xa8, 0x58, 0x8e, 0xb1, 0xc4,
+ 0x01, 0x3d, 0xe3, 0x08, 0x5a, 0x78, 0x86, 0xc8,
+ 0x48, 0x23, 0x62, 0x83, 0xab, 0x32, 0x84, 0xb6,
+ 0x17, 0x60, 0x65, 0xb6, 0xc0, 0xd4, 0xee, 0xda,
+ 0x22, 0xe3, 0x9d, 0x0b, 0x42, 0xda, 0x70, 0x94,
+ 0xc8, 0x58, 0xe6, 0x12, 0x27, 0x0a, 0xcd, 0x99,
+ 0x72, 0x04, 0xc1, 0x73, 0xae, 0xd9, 0xdd, 0xe3,
+ 0xa0, 0x36, 0x69, 0x2f, 0x89, 0xce, 0xa3, 0x04,
+ 0x6f, 0xb3, 0xd0, 0x82, 0xad, 0x02, 0x53, 0xf2,
+ 0xdc, 0x26, 0xc0, 0xbb, 0x2a, 0x94, 0x90, 0x41,
+ 0xb8, 0x45, 0xb2, 0x7e, 0x2b, 0x34, 0xca, 0x86,
+ 0x15, 0x19, 0xd0, 0x3a, 0xd3, 0x68, 0x24, 0x50,
+ 0x46, 0x03, 0x4e, 0x01, 0x00, 0x45, 0x22, 0x11,
+ 0xb0, 0xd1, 0x80, 0x05, 0xb1, 0xc2, 0x03, 0x9c,
+ 0x29, 0x40, 0xe7, 0x05, 0x40, 0x34, 0xc7, 0xcc,
+ 0x04, 0x12, 0x0d, 0x00, 0x54, 0xd0, 0x86, 0xb7,
+ 0x16, 0xc1, 0x2e, 0xe0, 0x1b, 0xee, 0xb8, 0x28,
+ 0x23, 0x2e, 0x14, 0x44, 0x45, 0x83, 0x2e, 0x3a,
+ 0x1a, 0x21, 0x4a, 0x05, 0xdc, 0x03, 0x7d, 0xd7,
+ 0x05, 0x04, 0x74, 0xc5, 0x10, 0x88, 0xb0, 0x65,
+ 0x52, 0x09, 0x9b, 0x80, 0x2b, 0x0e, 0x88, 0x6e,
+ 0x85, 0x38, 0x57, 0x71, 0xa7, 0x77, 0x21, 0xf0,
+ 0x2a, 0x20, 0xc0, 0x0a, 0xb7, 0xca, 0xc2, 0xa0,
+ 0x00, 0x05, 0xbc, 0x28, 0x18, 0xb6, 0x91, 0xe4,
+ 0x5c, 0x80, 0x38, 0x5b, 0x2b, 0x38, 0x06, 0x58,
+ 0x2c, 0x80, 0xa4, 0x15, 0x24, 0x90, 0x33, 0xc7,
+ 0x08, 0x01, 0x59, 0x49, 0x23, 0x84, 0x5e, 0xc4,
+ 0x5b, 0x3f, 0x01, 0xb2, 0x5a, 0x74, 0x4d, 0x12,
+ 0x26, 0x09, 0x06, 0x4f, 0x50, 0xc3, 0x03, 0x91,
+ 0x36, 0x57, 0x84, 0x25, 0x36, 0xbd, 0x02, 0xde,
+ 0x00, 0xc4, 0xd3, 0x09, 0xc0, 0x2e, 0x65, 0xae,
+ 0x46, 0x50, 0x22, 0x19, 0x8c, 0x8f, 0x40, 0xb9,
+ 0x93, 0xe4, 0xb2, 0xc7, 0xb4, 0x4b, 0x99, 0x6b,
+ 0xa3, 0x2e, 0x14, 0x46, 0xd3, 0x98, 0x6e, 0x16,
+ 0xd1, 0x68, 0x6d, 0x30, 0x9c, 0x01, 0x8c, 0x8f,
+ 0x40, 0xcb, 0x16, 0x74, 0x1f, 0xe2, 0x80, 0xad,
+ 0x30, 0x9c, 0x01, 0x96, 0x7b, 0x4c, 0xcb, 0x1e,
+ 0xd1, 0x19, 0x40, 0x88, 0x6c, 0xb1, 0xa4, 0x4b,
+ 0x2c, 0x29, 0x86, 0x7f, 0x09, 0x41, 0x9e, 0xc2,
+ 0x68, 0x4c, 0xa7, 0x88, 0x6c, 0x05, 0x96, 0x14,
+ 0xc3, 0x5c, 0xca, 0x01, 0x02, 0xa8, 0xc0, 0x07,
+ 0x0a, 0x30, 0x84, 0x83, 0x33, 0xa4, 0x5c, 0xd2,
+ 0x91, 0xd9, 0xa5, 0x1a, 0x23, 0x09, 0x05, 0x81,
+ 0xd6, 0x17, 0xc0, 0x69, 0x82, 0xc8, 0x17, 0x34,
+ 0xa4, 0x56, 0x49, 0xcf, 0x8c, 0x82, 0xf4, 0x0a,
+ 0x5b, 0xc0, 0x19, 0x19, 0xa6, 0x54, 0x22, 0xd9,
+ 0xb5, 0x8c, 0xf6, 0x13, 0x42, 0x70, 0x88, 0xb9,
+ 0x96, 0xf0, 0xa0, 0x47, 0x4c, 0x51, 0x04, 0x83,
+ 0x51, 0x6d, 0x74, 0xc5, 0x11, 0x4b, 0x60, 0x24,
+ 0x23, 0xbd, 0x46, 0x31, 0x97, 0x1f, 0x23, 0x20,
+ 0xd6, 0xd4, 0x5c, 0x2b, 0x36, 0x50, 0xa9, 0x49,
+ 0xa1, 0x86, 0x3e, 0x60, 0x2d, 0xc9, 0x1a, 0x1c,
+ 0xe1, 0x78, 0x07, 0x29, 0xf7, 0x01, 0xc3, 0x4d,
+ 0xc2, 0x78, 0x87, 0x18, 0x59, 0xe9, 0x98, 0xa6,
+ 0x1d, 0x8f, 0x20, 0x82, 0x58, 0xe0, 0x3c, 0xd9,
+ 0x89, 0x8f, 0xa9, 0xb6, 0xf6, 0x59, 0xea, 0x05,
+ 0xc3, 0x66, 0x46, 0x73, 0xda, 0x3a, 0x90, 0x29,
+ 0xb6, 0xf7, 0x33, 0x44, 0x56, 0x80, 0x5b, 0xb3,
+ 0x13, 0x9e, 0x6d, 0x59, 0x07, 0xd5, 0x17, 0x2b,
+ 0xbc, 0x74, 0x06, 0xe7, 0x5a, 0xb6, 0x39, 0xec,
+ 0xb1, 0x61, 0x45, 0x38, 0xbc, 0x01, 0x18, 0x92,
+ 0x43, 0x26, 0x17, 0xca, 0xf2, 0x65, 0x02, 0xa1,
+ 0x7e, 0x39, 0x61, 0x45, 0x27, 0x11, 0x08, 0xa4,
+ 0x42, 0xf9, 0x42, 0x39, 0x00, 0x46, 0x24, 0x96,
+ 0x22, 0xf0, 0x04, 0x52, 0x71, 0x58, 0x92, 0x52,
+ 0x27, 0x93, 0x89, 0xbb, 0xf1, 0x02, 0xa4, 0xd1,
+ 0x80, 0xc9, 0x02, 0x31, 0x2d, 0xe0, 0x0c, 0x21,
+ 0x57, 0x6d, 0x13, 0x84, 0x45, 0xcc, 0xe7, 0x17,
+ 0x80, 0x1d, 0xde, 0x7d, 0x65, 0xd0, 0x08, 0x03,
+ 0x84, 0x48, 0xce, 0x51, 0x79, 0xd6, 0xae, 0x6a,
+ 0xbd, 0x0b, 0x97, 0x9d, 0x69, 0x78, 0xbf, 0x8a,
+ 0x58, 0x30, 0x83, 0x50, 0x0c, 0x84, 0x05, 0xf2,
+ 0xfc, 0x15, 0x40, 0xda, 0x70, 0x31, 0x49, 0xe0,
+ 0x47, 0x7c, 0x7b, 0x63, 0x78, 0x80, 0x71, 0xc8,
+ 0xcb, 0x2d, 0xe3, 0xe0, 0x81, 0x52, 0x12, 0x0b,
+ 0x24, 0x12, 0x00, 0x61, 0xc8, 0xcc, 0xbc, 0x41,
+ 0x20, 0x06, 0xdc, 0x8c, 0xb3, 0x2e, 0xdc, 0x52,
+ 0x15, 0xbe, 0x15, 0xaa, 0xce, 0xc0, 0x0a, 0x5b,
+ 0xfd, 0xbb, 0xb4, 0xa5, 0x0c, 0xdc, 0x55, 0x8b,
+ 0x70, 0x1c, 0xa0, 0x36, 0x16, 0xee, 0xa4, 0x8c,
+ 0x86, 0x05, 0xa1, 0x75, 0xea, 0x50, 0x97, 0x28,
+ 0x64, 0x42, 0x89, 0xb4, 0x91, 0xbb, 0xa9, 0x23,
+ 0x64, 0x84, 0xa8, 0x50, 0x3a, 0xb2, 0x43, 0x19,
+ 0x6e, 0x90, 0xae, 0x58, 0xe2, 0x5b, 0xe6, 0x19,
+ 0x54, 0xf7, 0xc4, 0xa4, 0xc2, 0x79, 0x0c, 0x82,
+ 0x4c, 0xdf, 0x08, 0x51, 0x78, 0x01, 0x66, 0xca,
+ 0x78, 0x05, 0xb0, 0xe6, 0x7c, 0xab, 0xb9, 0x4b,
+ 0xa0, 0x18, 0x06, 0xe9, 0xfb, 0x89, 0xf2, 0x6d,
+ 0x24, 0x62, 0xca, 0x51, 0x1b, 0x23, 0x9c, 0x32,
+ 0x08, 0x5c, 0x01, 0xd7, 0x25, 0x01, 0x64, 0xd1,
+ 0xe9, 0x18, 0x62, 0x0a, 0x32, 0x0c, 0xb2, 0x01,
+ 0x96, 0x8c, 0x00, 0x27, 0x82, 0x78, 0x1d, 0x31,
+ 0x44, 0x02, 0x08, 0x0b, 0x01, 0xb2, 0x16, 0x00,
+ 0x69, 0x82, 0xa8, 0x4f, 0xc7, 0xf1, 0x09, 0x03,
+ 0x7c, 0xc1, 0xc4, 0xc6, 0x40, 0x8b, 0x81, 0x9f,
+ 0x20, 0xb4, 0x16, 0xf9, 0x83, 0x88, 0xc6, 0x97,
+ 0xe1, 0x72, 0x05, 0x65, 0x90, 0x61, 0x42, 0x8e,
+ 0xe0, 0x0c, 0xa7, 0x4b, 0x0c, 0x30, 0x80, 0xd8,
+ 0x4a, 0x3c, 0x7a, 0x53, 0xbb, 0xcf, 0xad, 0xb3,
+ 0xb8, 0x22, 0x20, 0xab, 0xc2, 0x48, 0x3b, 0xc6,
+ 0xb2, 0x0f, 0x1e, 0x14, 0x82, 0xf3, 0xcc, 0x32,
+ 0xf3, 0x5f, 0xcc, 0xbd, 0x19, 0x36, 0x59, 0xea,
+ 0x05, 0xb3, 0xb8, 0x23, 0x20, 0x86, 0x61, 0x4c,
+ 0x3c, 0xa4, 0x82, 0x0b, 0xcf, 0x31, 0xce, 0x40,
+ 0x20, 0x64, 0x84, 0xa8, 0x4a, 0x25, 0x56, 0x66,
+ 0xc8, 0x52, 0x81, 0x9e, 0x03, 0x21, 0x2d, 0xc0,
+ 0x99, 0x8c, 0xbe, 0x28, 0x53, 0x28, 0x4d, 0x01,
+ 0xbe, 0x08, 0x61, 0x0a, 0x80, 0xe0, 0x1b, 0x3b,
+ 0x82, 0x56, 0x1f, 0x91, 0x24, 0x82, 0x55, 0x85,
+ 0x7c, 0xf6, 0xc2, 0x42, 0xbe, 0x2a, 0x53, 0x1e,
+ 0xc2, 0x00, 0x82, 0x0b, 0x00, 0x6c, 0xa7, 0x80,
+ 0x5d, 0x22, 0xde, 0x03, 0x09, 0xc5, 0x88, 0x2a,
+ 0xe1, 0x40, 0x20, 0xf9, 0x08, 0xc2, 0xa5, 0x58,
+ 0x56, 0x1f, 0xa0, 0x29, 0xb6, 0x60, 0xc1, 0x0a,
+ 0xf9, 0xfa, 0xcc, 0x22, 0xd6, 0x43, 0x08, 0x08,
+ 0x00, 0xc6, 0x35, 0x06, 0x0a, 0xf8, 0x18, 0xd8,
+ 0xf4, 0xba, 0x12, 0x88, 0x3c, 0x00, 0xea, 0x0d,
+ 0x00, 0x32, 0x1d, 0x41, 0xa8, 0x05, 0xb0, 0x12,
+ 0x01, 0x90, 0xea, 0x13, 0xc0, 0x77, 0x95, 0x68,
+ 0x08, 0x3e, 0x66, 0xa6, 0x2f, 0x6e, 0x01, 0x97,
+ 0xe2, 0xe3, 0x62, 0x16, 0xca, 0x0c, 0x0c, 0x5f,
+ 0x84, 0x29, 0x6c, 0xa0, 0xc0, 0xc3, 0xf4, 0xd8,
+ 0xb1, 0x7f, 0x74, 0x2e, 0x90, 0x08, 0x03, 0x17,
+ 0xf3, 0x4a, 0x15, 0xfd, 0x13, 0xb0, 0xff, 0x28,
+ 0xc5, 0x7f, 0xb0, 0x43, 0x6f, 0xd5, 0xc6, 0x5b,
+ 0xfa, 0xf3, 0xb1, 0x7e, 0x5c, 0xc5, 0x7f, 0x60,
+ 0x3b, 0x85, 0x25, 0x04, 0x65, 0xf6, 0x09, 0x36,
+ 0x7d, 0x88, 0xee, 0xbf, 0x6b, 0xf3, 0x0c, 0x81,
+ 0x08, 0x61, 0xf4, 0x33, 0x31, 0x7c, 0xe0, 0x2e,
+ 0x7f, 0x03, 0x18, 0x57, 0x31, 0x7e, 0xad, 0xb1,
+ 0xd9, 0x17, 0x43, 0x09, 0x09, 0x46, 0xf3, 0x44,
+ 0x35, 0xc0, 0x5a, 0x48, 0x84, 0xa8, 0x1a, 0xee,
+ 0x5a, 0x12, 0x0e, 0xe5, 0x94, 0xa6, 0x03, 0x82,
+ 0x68, 0xab, 0x19, 0x18, 0xe1, 0xfa, 0x46, 0x41,
+ 0x6c, 0xc0, 0x80, 0xe5, 0x4d, 0x70, 0x33, 0x4b,
+ 0x78, 0x29, 0x30, 0xa6, 0x0b, 0x94, 0x6c, 0x40,
+ 0xe9, 0x45, 0xf0, 0x37, 0x42, 0x60, 0x05, 0x90,
+ 0xd8, 0x53, 0x20, 0xb6, 0x3a, 0xc0, 0x6f, 0x83,
+ 0x08, 0x0b, 0x7f, 0xab, 0x24, 0x6f, 0xea, 0x18,
+ 0xfe, 0x21, 0xc1, 0x28, 0xb4, 0x6f, 0xc8, 0x2d,
+ 0x1a, 0x12, 0xd1, 0x6d, 0xa3, 0xce, 0x41, 0x06,
+ 0x12, 0x9f, 0x9f, 0x6c, 0xa3, 0xf7, 0x5b, 0x28,
+ 0x8d, 0xf7, 0xf8, 0xb0, 0x7c, 0xb0, 0xb7, 0xdd,
+ 0x6c, 0x2c, 0x37, 0xcf, 0xc5, 0x34, 0xc6, 0x01,
+ 0x02, 0x73, 0xc7, 0xf8, 0x1b, 0xa1, 0xd6, 0x26,
+ 0x39, 0xe8, 0x00, 0xb6, 0x34, 0x80, 0x2d, 0x89,
+ 0xb8, 0x1d, 0x60, 0xb4, 0x10, 0xad, 0x24, 0x81,
+ 0x8f, 0xfc, 0xaf, 0x66, 0xf7, 0xe8, 0x82, 0xa6,
+ 0x78, 0x16, 0x1b, 0x7b, 0x89, 0xb3, 0xf9, 0xc3,
+ 0x70, 0xc6, 0x38, 0xcb, 0x61, 0x70, 0x27, 0x3a,
+ 0xc8, 0x69, 0xce, 0x1b, 0x23, 0x30, 0xa5, 0x48,
+ 0x5b, 0x36, 0x48, 0x57, 0x3a, 0x32, 0x84, 0xb6,
+ 0x96, 0x44, 0x6f, 0x83, 0x68, 0x1b, 0xa7, 0x8a,
+ 0x06, 0x63, 0x34, 0x53, 0x42, 0x41, 0xfb, 0x62,
+ 0x3a, 0xf2, 0x24, 0xe1, 0x53, 0xe7, 0x2b, 0x1c,
+ 0x20, 0x00, 0xb7, 0xb4, 0xa2, 0x1d, 0x42, 0xb0,
+ 0x01, 0x50, 0xb5, 0x0b, 0x7c, 0x08, 0x84, 0xdf,
+ 0x01, 0xd1, 0x18, 0x5d, 0x58, 0x61, 0x50, 0x9e,
+ 0x23, 0xad, 0x11, 0x82, 0xc9, 0x07, 0x30, 0x31,
+ 0xce, 0xc4, 0x8d, 0x3c, 0x5e, 0x0b, 0x1e, 0xc4,
+ 0x00, 0xc7, 0x98, 0x30, 0x85, 0x6c, 0x2c, 0xa6,
+ 0x30, 0x12, 0x03, 0x37, 0xdb, 0x4a, 0xd9, 0xf0,
+ 0xb6, 0x10, 0x41, 0xd4, 0x0e, 0xd3, 0x42, 0x03,
+ 0xa4, 0x11, 0xc6, 0xe9, 0xde, 0xe0, 0xb6, 0x7c,
+ 0xb0, 0x4c, 0xb0, 0x3a, 0x03, 0x7c, 0x12, 0x00,
+ 0xb7, 0xac, 0xf2, 0x19, 0x7f, 0x13, 0x0d, 0xf0,
+ 0x1d, 0x03, 0xa7, 0xf3, 0x26, 0xc9, 0xfc, 0xcf,
+ 0xb6, 0x7e, 0x61, 0xec, 0xdf, 0x5c, 0x8b, 0x37,
+ 0x5f, 0xc4, 0x41, 0xf9, 0x9b, 0xb4, 0xff, 0x36,
+ 0xed, 0x3f, 0x2a, 0xf3, 0x9f, 0xbb, 0xbe, 0xc3,
+ 0xee, 0xeb, 0x9d, 0x7a, 0xc8, 0x4d, 0x35, 0x32,
+ 0x13, 0xa4, 0x64, 0xc0, 0xc7, 0xe3, 0x75, 0x18,
+ 0xee, 0x44, 0x4e, 0x7e, 0x1b, 0x3b, 0x2f, 0xae,
+ 0x06, 0x63, 0xfe, 0xb5, 0x85, 0x49, 0x20, 0x2c,
+ 0x7e, 0x65, 0x13, 0x9f, 0x7d, 0x0e, 0xd3, 0x23,
+ 0x90, 0x36, 0x41, 0x30, 0x0e, 0xd0, 0x7f, 0x03,
+ 0x2d, 0x4f, 0x06, 0xd9, 0xfd, 0xa1, 0x31, 0xf7,
+ 0x81, 0x46, 0x13, 0x6c, 0x03, 0x1f, 0x74, 0x14,
+ 0xeb, 0xdf, 0x20, 0xb7, 0xc8, 0x1c, 0x0d, 0x31,
+ 0xd1, 0x03, 0x1c, 0x6f, 0x8c, 0x61, 0xdf, 0x05,
+ 0x31, 0xf7, 0x04, 0xad, 0xfd, 0x9c, 0x49, 0x5f,
+ 0x76, 0x82, 0xc7, 0xd8, 0xb5, 0x16, 0xc0, 0x54,
+ 0x0d, 0x9d, 0x3f, 0x08, 0x54, 0xc4, 0x86, 0xc9,
+ 0x8c, 0xe1, 0x10, 0x4b, 0x11, 0x8e, 0x75, 0xda,
+ 0x03, 0xa6, 0x1f, 0xc4, 0xc7, 0xf9, 0xc4, 0x14,
+ 0xc5, 0x60, 0x0f, 0x94, 0xa9, 0x49, 0x05, 0x34,
+ 0x90, 0x15, 0xbf, 0x71, 0x34, 0xd2, 0x3c, 0xc6,
+ 0x5f, 0xe6, 0x5b, 0xed, 0x1d, 0x90, 0x67, 0xfc,
+ 0xd5, 0x32, 0x52, 0x28, 0x61, 0x54, 0x59, 0x39,
+ 0xa7, 0xec, 0x14, 0x61, 0x34, 0xc7, 0xbd, 0xf2,
+ 0xcd, 0xac, 0xdd, 0x30, 0x4b, 0x9f, 0xd5, 0x06,
+ 0xdc, 0x4c, 0xc6, 0xc9, 0x1f, 0x26, 0x85, 0x03,
+ 0xff, 0x8f, 0x11, 0x92, 0x0e, 0xe1, 0x74, 0x88,
+ 0xe8, 0x1b, 0x3f, 0x96, 0x80, 0xa9, 0x58, 0x85,
+ 0xde, 0xff, 0x63, 0x6e, 0xfe, 0x11, 0x4c, 0x7c,
+ 0x50, 0x36, 0xef, 0xda, 0x10, 0x2a, 0x80, 0x44,
+ 0x0a, 0xfd, 0x29, 0x8c, 0x21, 0xba, 0x20, 0xad,
+ 0xf9, 0x5d, 0xd3, 0x97, 0xa5, 0x0a, 0xe4, 0x9d,
+ 0x18, 0x79, 0x34, 0x16, 0x98, 0x0d, 0x81, 0x9b,
+ 0xa3, 0x52, 0x61, 0xff, 0x20, 0xc8, 0x05, 0x06,
+ 0x6b, 0xfd, 0x19, 0x96, 0x5c, 0x22, 0x28, 0xff,
+ 0x91, 0xdb, 0xa6, 0x40, 0x76, 0x6f, 0xe0, 0xed,
+ 0xb3, 0xf8, 0x4a, 0x6c, 0xfe, 0x1a, 0xdb, 0xbb,
+ 0x42, 0x62, 0x09, 0x08, 0x08, 0xa7, 0x29, 0x44,
+ 0x2d, 0xf0, 0xc1, 0x0c, 0x77, 0x3c, 0x02, 0x09,
+ 0x5f, 0x85, 0x8a, 0x41, 0x2d, 0x0a, 0xf6, 0x3f,
+ 0xd9, 0x7d, 0xe5, 0xf7, 0x3f, 0x79, 0x7d, 0x9f,
+ 0xde, 0x55, 0x0a, 0xcb, 0xac, 0x98, 0xf2, 0xc3,
+ 0x12, 0x8f, 0x65, 0x18, 0x2a, 0x3f, 0xc3, 0x63,
+ 0xc8, 0xca, 0xd8, 0xf2, 0x16, 0xb2, 0x8f, 0xeb,
+ 0x1d, 0xbb, 0xd5, 0xdf, 0x20, 0xfb, 0xed, 0x4a,
+ 0x3d, 0x34, 0x50, 0xaf, 0xc9, 0x44, 0xa3, 0xf4,
+ 0x2c, 0x6e, 0x8b, 0x48, 0x9c, 0xbb, 0x76, 0x46,
+ 0x5e, 0x93, 0x10, 0x82, 0xb5, 0x08, 0x6c, 0xea,
+ 0x12, 0x4c, 0xbc, 0xfd, 0xf2, 0x0e, 0xa2, 0xb4,
+ 0xce, 0x4c, 0x00, 0x20, 0xa9, 0xf9, 0x1b, 0x39,
+ 0xf4, 0x93, 0x08, 0x9b, 0x8c, 0xca, 0x22, 0x89,
+ 0x72, 0xfc, 0x0a, 0x9b, 0x39, 0x9e, 0x93, 0x39,
+ 0x0f, 0x80, 0xfa, 0x97, 0xe6, 0x73, 0x3c, 0xc4,
+ 0xdc, 0x0c, 0x33, 0xa7, 0x03, 0x2c, 0x76, 0xc0,
+ 0xdf, 0x9b, 0xc0, 0xb7, 0x72, 0x44, 0x04, 0x18,
+ 0x62, 0x03, 0x65, 0x45, 0xc6, 0xd9, 0x48, 0x50,
+ 0x32, 0xd2, 0xe0, 0x07, 0x71, 0x2b, 0x41, 0x05,
+ 0xee, 0x4a, 0x5b, 0x14, 0x10, 0x36, 0x1e, 0x63,
+ 0x22, 0x85, 0xb9, 0xa0, 0x14, 0xba, 0xed, 0xe8,
+ 0x4d, 0x20, 0x94, 0x89, 0x73, 0x8b, 0x01, 0x05,
+ 0xdf, 0x46, 0x75, 0x5f, 0x40, 0x30, 0x9c, 0x8d,
+ 0x73, 0xa4, 0x09, 0x44, 0x9b, 0x00, 0xdd, 0x3b,
+ 0x40, 0x91, 0x43, 0xc8, 0x8c, 0x70, 0xa0, 0x03,
+ 0x0c, 0x36, 0x02, 0xcf, 0x17, 0xb4, 0x96, 0x7f,
+ 0xc8, 0x6d, 0xf1, 0xed, 0x03, 0x2c, 0xe7, 0x08,
+ 0x59, 0x55, 0x80, 0x9f, 0xe1, 0x6c, 0x04, 0x17,
+ 0x61, 0x03, 0x66, 0xaf, 0x84, 0xc8, 0x6f, 0x8b,
+ 0x80, 0x42, 0xa5, 0xc0, 0x07, 0x3f, 0xed, 0x9d,
+ 0x72, 0x7d, 0xa0, 0x6c, 0x8d, 0xb8, 0x48, 0x23,
+ 0x64, 0x56, 0xff, 0xe3, 0x08, 0x2a, 0x05, 0x62,
+ 0x62, 0x37, 0x99, 0x0f, 0x31, 0x9a, 0x0b, 0x74,
+ 0xd1, 0x44, 0xc9, 0x06, 0x51, 0x34, 0x4f, 0x68,
+ 0x24, 0x10, 0x7b, 0x03, 0x0d, 0x4f, 0x82, 0xe9,
+ 0x01, 0xe0, 0xb9, 0x44, 0x04, 0x0c, 0xb0, 0x10,
+ 0x02, 0x44, 0xba, 0x00, 0x8b, 0x5d, 0x71, 0x36,
+ 0xd8, 0x80, 0x0f, 0x10, 0xe8, 0x03, 0x0d, 0x31,
+ 0xc2, 0x15, 0x32, 0x52, 0x14, 0x41, 0x68, 0x0c,
+ 0xd5, 0x72, 0x03, 0x1c, 0x31, 0xc8, 0x5a, 0x77,
+ 0xb5, 0xe0, 0x08, 0x20, 0x84, 0x06, 0x4b, 0x98,
+ 0x89, 0x96, 0x19, 0xc8, 0x66, 0x8a, 0x28, 0x19,
+ 0xe1, 0x7e, 0x17, 0x7f, 0xf1, 0x84, 0xa3, 0xfa,
+ 0x23, 0x29, 0xa7, 0xc0, 0x19, 0x69, 0xbe, 0x02,
+ 0xb9, 0x71, 0x15, 0xce, 0x5d, 0x22, 0x28, 0x9f,
+ 0x39, 0x58, 0xe6, 0x8e, 0x22, 0xda, 0x33, 0x0c,
+ 0xa6, 0x6c, 0xe5, 0x65, 0xa5, 0xa0, 0x1c, 0xe9,
+ 0x5a, 0x17, 0x3f, 0xec, 0x91, 0xb2, 0x39, 0xc0,
+ 0x74, 0xfc, 0xc0, 0x8b, 0x74, 0x7e, 0x57, 0x58,
+ 0x36, 0x84, 0xa7, 0xe0, 0x44, 0x0a, 0x94, 0x91,
+ 0x19, 0x28, 0x42, 0x37, 0x7f, 0xee, 0x99, 0xdf,
+ 0xed, 0x81, 0x77, 0xfb, 0x40, 0xcf, 0xa1, 0x6a,
+ 0x56, 0x6f, 0xb8, 0x29, 0xdf, 0xf6, 0xa6, 0x29,
+ 0xfb, 0x58, 0xcb, 0x73, 0x46, 0x46, 0x4f, 0x7b,
+ 0x08, 0xee, 0x15, 0xec, 0x4f, 0x27, 0x94, 0x2b,
+ 0x3d, 0xf6, 0xea, 0xcf, 0x01, 0x9a, 0xb9, 0xa1,
+ 0x20, 0x27, 0x8b, 0x49, 0xf7, 0x81, 0x0b, 0xa4,
+ 0x05, 0x00, 0xe7, 0x5c, 0xa0, 0xb9, 0xd6, 0x7c,
+ 0x86, 0x23, 0x7a, 0xd8, 0x8c, 0xb4, 0xed, 0x23,
+ 0x90, 0xb1, 0x1d, 0x6c, 0x0a, 0x07, 0x2a, 0x6a,
+ 0x01, 0xbf, 0x22, 0x41, 0x61, 0x91, 0x68, 0x1b,
+ 0xff, 0xee, 0x22, 0x09, 0x36, 0x01, 0x9a, 0x47,
+ 0xc0, 0x69, 0xac, 0xc8, 0x9c, 0xee, 0xa0, 0x07,
+ 0x39, 0x36, 0x89, 0xd7, 0xd5, 0x44, 0x63, 0xf8,
+ 0x60, 0x5c, 0xe6, 0xee, 0x16, 0x3f, 0xf8, 0x28,
+ 0x82, 0x31, 0x02, 0x70, 0xb4, 0x60, 0xdb, 0x6d,
+ 0xbe, 0x06, 0x8f, 0x1d, 0x00, 0x82, 0x30, 0x05,
+ 0x72, 0x90, 0x30, 0x0e, 0xa2, 0xf6, 0x46, 0x3a,
+ 0xc6, 0x18, 0xa7, 0x6a, 0x2a, 0x70, 0x80, 0xa1,
+ 0xdb, 0x23, 0xfe, 0x26, 0x13, 0x64, 0x91, 0x42,
+ 0xc7, 0xd5, 0x25, 0x1d, 0x48, 0xb0, 0x4d, 0xe6,
+ 0xb8, 0xa3, 0x00, 0xb7, 0xf4, 0xe4, 0x29, 0xe8,
+ 0xb8, 0x58, 0xff, 0x1a, 0x33, 0x29, 0xc9, 0x01,
+ 0x86, 0x46, 0x04, 0x63, 0xfb, 0xe8, 0xcc, 0x32,
+ 0x08, 0x26, 0xcf, 0xb9, 0x89, 0xe3, 0x04, 0xc2,
+ 0x7c, 0xff, 0x9a, 0x0b, 0x62, 0x24, 0x07, 0xd9,
+ 0x89, 0x81, 0xb3, 0xeb, 0x02, 0x6e, 0x87, 0x58,
+ 0x98, 0xfe, 0x9a, 0x36, 0x3f, 0x05, 0x0d, 0x02,
+ 0x50, 0x62, 0x6c, 0xff, 0x80, 0xcb, 0x69, 0xd6,
+ 0x57, 0x7e, 0xe4, 0x0d, 0xcf, 0xac, 0x83, 0x2d,
+ 0x89, 0xf8, 0x9b, 0x2b, 0x18, 0x07, 0x49, 0x85,
+ 0x8d, 0xb3, 0xee, 0xca, 0x20, 0xfb, 0xbd, 0x9e,
+ 0x22, 0xdc, 0x07, 0xdf, 0xc8, 0xa8, 0xa3, 0xe7,
+ 0xed, 0x28, 0xfa, 0xa8, 0xde, 0x3e, 0xb6, 0x47,
+ 0x8f, 0xb0, 0x8c, 0xa6, 0x4c, 0xa5, 0x6e, 0x82,
+ 0x60, 0x9d, 0x0f, 0x31, 0x2a, 0x01, 0x00, 0xba,
+ 0x00, 0xc0, 0x6e, 0xe8, 0x68, 0x59, 0xa1, 0x8a,
+ 0x16, 0x4e, 0x10, 0x88, 0x8b, 0xe7, 0xe5, 0x62,
+ 0xe6, 0xf2, 0x5d, 0x3f, 0xae, 0x10, 0xa9, 0xe9,
+ 0x80, 0x82, 0x15, 0xa3, 0x0a, 0x93, 0x22, 0x19,
+ 0xa1, 0x08, 0x06, 0x4f, 0x3c, 0x14, 0xb7, 0xde,
+ 0x81, 0x5c, 0xfb, 0xc9, 0x48, 0x3c, 0xaa, 0x42,
+ 0xdf, 0xac, 0x24, 0xa7, 0x11, 0x8a, 0x6c, 0xf4,
+ 0xc2, 0x82, 0xa7, 0x4c, 0x36, 0x13, 0xa7, 0xbf,
+ 0x42, 0xdb, 0xe2, 0xe2, 0x14, 0x56, 0x10, 0x2e,
+ 0x74, 0x77, 0x0b, 0x1f, 0xaf, 0xce, 0x5b, 0x3b,
+ 0xa4, 0x1e, 0x7e, 0x44, 0xae, 0x66, 0x93, 0x3c,
+ 0x26, 0x80, 0xe9, 0x7f, 0xc0, 0x32, 0xed, 0x60,
+ 0x0c, 0xa7, 0x88, 0x95, 0x81, 0x9a, 0x75, 0x84,
+ 0x6c, 0xf6, 0x42, 0xd8, 0xff, 0x54, 0x20, 0xa8,
+ 0xdd, 0x89, 0x94, 0xf0, 0x65, 0x88, 0x38, 0x1b,
+ 0x7f, 0x43, 0xf2, 0xdf, 0xd0, 0xc8, 0xa7, 0xf5,
+ 0x4d, 0x65, 0xfd, 0xa0, 0x5d, 0x60, 0x22, 0x13,
+ 0xb8, 0x07, 0x84, 0xb4, 0x5b, 0xad, 0x90, 0x14,
+ 0x7d, 0x45, 0xc5, 0xb0, 0x07, 0x01, 0xf8, 0xfe,
+ 0x4e, 0xe0, 0x29, 0xb1, 0xb0, 0x58, 0x6d, 0xae,
+ 0x14, 0x0d, 0x43, 0x90, 0x2b, 0xda, 0x6d, 0x65,
+ 0xfd, 0xc9, 0x59, 0x62, 0x18, 0x27, 0x0e, 0x97,
+ 0x29, 0xc3, 0xaa, 0xa6, 0x65, 0xfa, 0x52, 0x02,
+ 0xa1, 0xde, 0x52, 0x08, 0x15, 0xa9, 0x8f, 0xf0,
+ 0x57, 0x20, 0xf7, 0x62, 0x5c, 0xfe, 0xf5, 0xa6,
+ 0x3f, 0x6e, 0x8d, 0x97, 0xef, 0x98, 0x63, 0xf3,
+ 0x32, 0x42, 0xbe, 0xf7, 0x26, 0xdf, 0x4a, 0x15,
+ 0xcb, 0x4a, 0x42, 0x20, 0xd3, 0xe8, 0xc8, 0x35,
+ 0x44, 0xa6, 0xcf, 0x61, 0xc8, 0x82, 0x52, 0x02,
+ 0x66, 0xdf, 0x48, 0x9b, 0xb4, 0x1e, 0x16, 0x4e,
+ 0x81, 0x9c, 0x83, 0xc0, 0xc6, 0x2d, 0x3b, 0x4a,
+ 0xa0, 0x21, 0x5f, 0xf2, 0x59, 0x04, 0x74, 0x04,
+ 0x7d, 0xb3, 0x33, 0x34, 0xee, 0xb4, 0x2e, 0x75,
+ 0xf9, 0x59, 0xee, 0x53, 0x80, 0xb9, 0x12, 0xe0,
+ 0x1d, 0x72, 0x68, 0xcd, 0xb2, 0xc0, 0x03, 0x0e,
+ 0x6d, 0xc6, 0x41, 0xbe, 0x54, 0x1f, 0xf9, 0xa4,
+ 0x44, 0x13, 0x26, 0x0b, 0x7e, 0x64, 0x40, 0xe7,
+ 0x10, 0xc3, 0x90, 0x75, 0xdc, 0xac, 0x90, 0xc6,
+ 0x13, 0x37, 0xb8, 0x1a, 0xdf, 0x0e, 0x81, 0x96,
+ 0x67, 0x6c, 0x87, 0x79, 0x15, 0xb1, 0xd6, 0x77,
+ 0x42, 0x7b, 0xf8, 0x03, 0x16, 0xfe, 0x2e, 0x4d,
+ 0x94, 0xcc, 0x13, 0x17, 0x34, 0x02, 0x41, 0xf8,
+ 0x96, 0x90, 0x49, 0xf8, 0x2c, 0x7b, 0x0d, 0x5b,
+ 0x1e, 0xc3, 0xd6, 0x81, 0x56, 0x41, 0xb8, 0x6d,
+ 0x04, 0xc7, 0xb9, 0x1f, 0x01, 0xdf, 0xde, 0xb6,
+ 0xb7, 0x63, 0xc0, 0xb9, 0xe4, 0xa4, 0x4c, 0x3e,
+ 0xfc, 0x0b, 0xcf, 0xba, 0xc2, 0x59, 0x91, 0x30,
+ 0x3a, 0xc4, 0xb0, 0x0c, 0x5c, 0x55, 0x0b, 0x9c,
+ 0x8c, 0x80, 0x41, 0x1c, 0x90, 0xb4, 0xe0, 0xf0,
+ 0x0d, 0xf2, 0x0a, 0x03, 0x6e, 0xb0, 0x46, 0xe7,
+ 0xf9, 0x27, 0x05, 0x53, 0x79, 0xe6, 0x59, 0xa6,
+ 0x23, 0x1e, 0xd1, 0x18, 0xc7, 0xa9, 0xa4, 0x39,
+ 0xc0, 0xf0, 0x0b, 0xb0, 0x3d, 0x43, 0xbd, 0x33,
+ 0x04, 0x41, 0xb1, 0x47, 0x94, 0xf1, 0x91, 0xa5,
+ 0x1b, 0xe4, 0x53, 0x24, 0x0c, 0x82, 0xc7, 0xe9,
+ 0x63, 0x14, 0x7f, 0x99, 0xc7, 0xe6, 0xf3, 0x11,
+ 0xab, 0x88, 0x20, 0x74, 0x97, 0x88, 0x97, 0x04,
+ 0x04, 0x98, 0xf8, 0x85, 0x8b, 0xfe, 0x23, 0x6d,
+ 0x32, 0x9b, 0x68, 0x64, 0x07, 0x2c, 0x02, 0x81,
+ 0x9e, 0x1a, 0xe1, 0x6e, 0x32, 0x9d, 0xf4, 0xa6,
+ 0x42, 0xec, 0xbe, 0x01, 0xd3, 0x06, 0xa1, 0x77,
+ 0x82, 0x18, 0x19, 0x7d, 0xfe, 0x17, 0x33, 0xae,
+ 0x08, 0x42, 0xe7, 0xa7, 0x63, 0x85, 0x66, 0x60,
+ 0x0e, 0x18, 0x0c, 0x03, 0x16, 0x01, 0x42, 0x41,
+ 0xa6, 0xc4, 0x37, 0x7f, 0x14, 0x05, 0xb9, 0xa5,
+ 0x21, 0x4d, 0x2e, 0x88, 0xc9, 0x33, 0xd1, 0x14,
+ 0x68, 0x10, 0xa5, 0x36, 0x57, 0x59, 0x04, 0xc8,
+ 0x08, 0xc9, 0xdf, 0x4e, 0xb2, 0x1b, 0xe1, 0x70,
+ 0x06, 0xee, 0x9c, 0x20, 0x2b, 0x9d, 0x64, 0x28,
+ 0xd9, 0x4b, 0x98, 0x60, 0x58, 0x15, 0xb8, 0x0b,
+ 0x11, 0x76, 0x55, 0x02, 0x61, 0xff, 0x80, 0x99,
+ 0x8d, 0x32, 0x8e, 0x03, 0x24, 0x0a, 0x00, 0x53,
+ 0xf5, 0x41, 0xa0, 0x49, 0x88, 0x27, 0x72, 0x79,
+ 0x0b, 0x0c, 0x00, 0x82, 0x5b, 0x7d, 0x80, 0x34,
+ 0x9d, 0x0e, 0x79, 0x1c, 0x13, 0x7c, 0x6b, 0x08,
+ 0xe6, 0x69, 0xa8, 0x50, 0x08, 0x2d, 0x9e, 0x86,
+ 0xf8, 0xcb, 0x0c, 0x9e, 0xd8, 0xe7, 0x20, 0xbd,
+ 0xc8, 0xcb, 0x24, 0x40, 0x16, 0x4f, 0xb8, 0xb4,
+ 0xef, 0x51, 0xe2, 0x68, 0x97, 0xe8, 0x4e, 0xa8,
+ 0x22, 0x36, 0xf8, 0xae, 0x91, 0xb8, 0x87, 0x78,
+ 0xe1, 0x91, 0x7e, 0xbe, 0x04, 0x04, 0x3e, 0x12,
+ 0x11, 0xbb, 0xf9, 0x43, 0x20, 0xf4, 0x41, 0x0b,
+ 0xa2, 0xec, 0x06, 0x8e, 0x35, 0x89, 0x87, 0xec,
+ 0xa9, 0x3b, 0xfd, 0x39, 0x4e, 0xbf, 0x51, 0xf6,
+ 0x5f, 0xd4, 0x28, 0xc7, 0xf5, 0x0c, 0x31, 0xfb,
+ 0x19, 0x8e, 0xf3, 0xce, 0x26, 0x5b, 0x7c, 0x84,
+ 0xeb, 0xeb, 0x5f, 0x27, 0xb5, 0x19, 0x5c, 0xec,
+ 0x5a, 0x07, 0x2b, 0x1e, 0x05, 0xa7, 0x3c, 0x80,
+ 0x65, 0x80, 0xf8, 0x1c, 0xaa, 0x7a, 0x16, 0x4f,
+ 0x63, 0x9c, 0x2b, 0xf6, 0x26, 0x3a, 0xf8, 0x67,
+ 0xc9, 0xe2, 0x60, 0x13, 0x1f, 0xc2, 0x98, 0xef,
+ 0xc5, 0xe4, 0x61, 0x33, 0x99, 0xe3, 0x22, 0x06,
+ 0x78, 0xf4, 0x09, 0xbf, 0xae, 0x43, 0x69, 0x33,
+ 0x54, 0x7c, 0x0c, 0x9e, 0x28, 0xa3, 0x85, 0x79,
+ 0x42, 0x5b, 0x5b, 0x50, 0x96, 0xe4, 0xe4, 0xec,
+ 0x3d, 0x9e, 0x39, 0x95, 0x71, 0x04, 0xd3, 0x92,
+ 0x10, 0x90, 0x77, 0xf0, 0xa5, 0xbf, 0xf8, 0x33,
+ 0x7c, 0x0b, 0x48, 0x53, 0xfd, 0xd0, 0x39, 0xd7,
+ 0x98, 0x4c, 0x9d, 0x7a, 0x23, 0x0f, 0xf8, 0x1c,
+ 0xd3, 0xfc, 0x41, 0x14, 0x82, 0xab, 0xce, 0x76,
+ 0x1e, 0xca, 0x8c, 0x83, 0xf3, 0xc8, 0x3b, 0x82,
+ 0x48, 0x5b, 0xf9, 0x9e, 0x03, 0xaa, 0x2c, 0x05,
+ 0xbe, 0x03, 0xc4, 0x63, 0xd7, 0x82, 0xdb, 0xfb,
+ 0xb0, 0x57, 0xd9, 0x0a, 0x04, 0x8a, 0x92, 0x23,
+ 0x0a, 0xee, 0x79, 0x99, 0xa0, 0x00, 0x32, 0xcb,
+ 0x84, 0x94, 0xb2, 0xe6, 0xc5, 0x6d, 0xd5, 0xb9,
+ 0x0f, 0xb9, 0x2e, 0x22, 0xde, 0xc5, 0x8d, 0xbf,
+ 0xaf, 0xe4, 0x2b, 0xed, 0x30, 0x98, 0x7d, 0xd0,
+ 0x73, 0xbe, 0xab, 0x89, 0xca, 0xd4, 0xc0, 0x79,
+ 0xf2, 0x8a, 0x88, 0x34, 0xe6, 0x92, 0x2e, 0xaa,
+ 0x45, 0xb2, 0x09, 0x85, 0x6d, 0xd2, 0x90, 0x98,
+ 0xed, 0x8c, 0x46, 0xfe, 0x08, 0x81, 0xcf, 0xa3,
+ 0x66, 0x7c, 0xfb, 0x1f, 0xdd, 0x3e, 0xc6, 0xd6,
+ 0xef, 0xe0, 0x8c, 0xab, 0xeb, 0x79, 0x72, 0x83,
+ 0x40, 0x0e, 0xb9, 0x72, 0x86, 0x3f, 0xaf, 0xfd,
+ 0x87, 0xeb, 0xed, 0x6f, 0xfb, 0x2f, 0x9b, 0xfd,
+ 0x10, 0x56, 0x5a, 0x09, 0x04, 0x2b, 0x80, 0x6a,
+ 0x20, 0xee, 0xfa, 0xdc, 0x0e, 0x9c, 0x2b, 0x03,
+ 0x4f, 0x7d, 0x44, 0xe1, 0xff, 0x70, 0xb1, 0xf7,
+ 0x7e, 0xae, 0x1f, 0xe4, 0x3b, 0x87, 0xf4, 0x42,
+ 0xdf, 0xdd, 0xb8, 0x95, 0xce, 0xcc, 0xa1, 0x54,
+ 0x47, 0x6a, 0xb1, 0x0c, 0x82, 0x4c, 0x26, 0x51,
+ 0x16, 0xe7, 0x42, 0x03, 0xb4, 0x07, 0x02, 0xd9,
+ 0x4c, 0xc1, 0x38, 0x40, 0xac, 0x0c, 0x26, 0xd3,
+ 0x1c, 0xa8, 0x42, 0x45, 0x28, 0x25, 0x3a, 0xe5,
+ 0xed, 0x87, 0x13, 0x74, 0x0b, 0x24, 0xe5, 0xce,
+ 0x63, 0x33, 0xa0, 0x39, 0x4b, 0x60, 0x24, 0x32,
+ 0x9f, 0x0a, 0x59, 0xb0, 0xea, 0x64, 0x92, 0xe0,
+ 0x08, 0x20, 0x46, 0x12, 0x08, 0x14, 0x85, 0x9e,
+ 0x59, 0x41, 0x74, 0x81, 0x10, 0x0b, 0x8e, 0xc7,
+ 0x42, 0x1c, 0xc9, 0xc6, 0xc5, 0x00, 0xa0, 0x37,
+ 0xca, 0x9c, 0x2d, 0x3b, 0x67, 0x03, 0x9d, 0x05,
+ 0x88, 0xca, 0x64, 0xde, 0x30, 0x5c, 0xaf, 0xa8,
+ 0x32, 0xc9, 0x24, 0x05, 0x73, 0xf0, 0x0a, 0x69,
+ 0x80, 0x40, 0x19, 0x63, 0x2e, 0x02, 0xd9, 0x01,
+ 0x89, 0x92, 0xf7, 0x03, 0x5c, 0xf6, 0x47, 0xcb,
+ 0x74, 0x8a, 0x66, 0xed, 0x12, 0x84, 0xca, 0x4c,
+ 0xe0, 0x76, 0xf9, 0x58, 0x88, 0x3f, 0x54, 0x77,
+ 0x3d, 0x69, 0x99, 0xa7, 0x91, 0xa8, 0x6f, 0xd6,
+ 0x09, 0x0b, 0x63, 0x38, 0x23, 0xbf, 0x7c, 0x19,
+ 0xca, 0x2f, 0x60, 0x30, 0x3c, 0x0e, 0x06, 0x03,
+ 0x0f, 0xff, 0x00, 0xc3, 0xff, 0x60, 0x20, 0x88,
+ 0xb8, 0x5d, 0xbd, 0xc4, 0x43, 0xb8, 0xde, 0x85,
+ 0x0f, 0xf5, 0xa2, 0x77, 0x9a, 0xe8, 0x1a, 0x23,
+ 0xd4, 0x17, 0x48, 0xbb, 0x01, 0xbb, 0x48, 0xe3,
+ 0x65, 0x9b, 0xa0, 0x59, 0x23, 0x22, 0x06, 0x98,
+ 0x1f, 0x01, 0x93, 0x5e, 0xa0, 0x53, 0x96, 0x7a,
+ 0x91, 0x89, 0x84, 0xf2, 0x09, 0x53, 0xd1, 0x1e,
+ 0x66, 0xd4, 0x21, 0x1c, 0x3d, 0x0a, 0x62, 0xd1,
+ 0xe4, 0x41, 0x84, 0x7d, 0x10, 0x80, 0x33, 0x75,
+ 0x80, 0x24, 0x12, 0x26, 0x0b, 0xc7, 0xdc, 0xd2,
+ 0x15, 0xe7, 0x3f, 0xb9, 0x79, 0xcf, 0xee, 0xbe,
+ 0x73, 0xf9, 0x67, 0x9c, 0xfe, 0x51, 0xd3, 0xbf,
+ 0xb6, 0x79, 0xce, 0x2c, 0xde, 0x38, 0x23, 0x87,
+ 0x9c, 0x3e, 0x41, 0xf0, 0x42, 0x9d, 0x82, 0x8b,
+ 0x73, 0x9d, 0x1a, 0xec, 0x10, 0x42, 0x8d, 0xea,
+ 0x96, 0x05, 0x7f, 0x9a, 0x4a, 0xdd, 0x17, 0x10,
+ 0x55, 0x06, 0xc2, 0xdd, 0x0e, 0x10, 0x31, 0xc7,
+ 0x6c, 0x65, 0x10, 0x16, 0x03, 0x65, 0x6a, 0xc2,
+ 0xd3, 0x06, 0x90, 0x30, 0xe2, 0x70, 0x4e, 0x78,
+ 0xd6, 0x0a, 0xee, 0x34, 0x08, 0x5b, 0xd2, 0x41,
+ 0x39, 0xc2, 0x14, 0x44, 0x30, 0x53, 0x50, 0x54,
+ 0x37, 0x08, 0x7d, 0x12, 0x42, 0x2e, 0x51, 0xf4,
+ 0x2e, 0x10, 0x34, 0x03, 0xa4, 0x6b, 0x00, 0xc7,
+ 0x6c, 0x70, 0xba, 0xc7, 0x74, 0x0c, 0x90, 0x6f,
+ 0x0b, 0xbc, 0x98, 0x14, 0xe7, 0x15, 0x60, 0x38,
+ 0x7e, 0x47, 0xef, 0x5f, 0x91, 0x21, 0x07, 0xda,
+ 0x10, 0x77, 0x21, 0x30, 0xba, 0x55, 0x34, 0xc4,
+ 0x07, 0x08, 0x8c, 0x81, 0xda, 0x1b, 0x00, 0x75,
+ 0x88, 0x48, 0x0e, 0xaf, 0x9c, 0x26, 0x4b, 0xe5,
+ 0xa0, 0x82, 0xb7, 0x84, 0x0a, 0xb5, 0x38, 0x4e,
+ 0xa4, 0xc0, 0x06, 0x4f, 0xf3, 0xa5, 0x92, 0x94,
+ 0x23, 0x5b, 0x87, 0x63, 0x50, 0x2d, 0x00, 0x02,
+ 0x08, 0x95, 0x14, 0x80, 0x77, 0x24, 0x00, 0x32,
+ 0xd3, 0x10, 0x0d, 0x87, 0x5d, 0x37, 0x15, 0xba,
+ 0x0f, 0x00, 0x61, 0x86, 0xb8, 0x02, 0xa3, 0x46,
+ 0x76, 0x3a, 0x2c, 0x8c, 0x2a, 0x77, 0x48, 0x30,
+ 0xe3, 0xd8, 0xd3, 0x8a, 0xbb, 0xd5, 0x01, 0x05,
+ 0x90, 0x44, 0xdd, 0x96, 0x72, 0x85, 0x52, 0x4c,
+ 0x45, 0x90, 0xa3, 0x0b, 0xbc, 0x57, 0x00, 0x15,
+ 0x5a, 0xd0, 0x29, 0xee, 0x9f, 0xee, 0x50, 0x35,
+ 0x0a, 0xee, 0xe9, 0x48, 0x69, 0x84, 0xa2, 0x10,
+ 0x70, 0x88, 0x4d, 0x32, 0x36, 0x33, 0x9d, 0xd4,
+ 0x82, 0x15, 0xe2, 0x80, 0x36, 0x40, 0x78, 0x0b,
+ 0xa0, 0xa1, 0x9f, 0xf7, 0xf2, 0xdd, 0xe0, 0x71,
+ 0x05, 0x50, 0x85, 0xec, 0x93, 0xa8, 0x1b, 0x24,
+ 0x18, 0x80, 0x15, 0x04, 0x90, 0x32, 0xce, 0xf0,
+ 0xad, 0xb4, 0x1e, 0x0b, 0x1d, 0x33, 0x86, 0xdb,
+ 0xff, 0x63, 0x10, 0x50, 0xf0, 0x6c, 0x70, 0x8f,
+ 0x2b, 0x14, 0x06, 0x40, 0xdd, 0x3a, 0x44, 0x05,
+ 0x7f, 0x69, 0xce, 0xb4, 0x99, 0x51, 0x0d, 0xb6,
+ 0x44, 0xc9, 0x64, 0x74, 0x05, 0x4e, 0x11, 0x87,
+ 0xd0, 0x5a, 0x20, 0x54, 0xc6, 0x4a, 0x5d, 0x5a,
+ 0x60, 0x38, 0x5a, 0x88, 0x25, 0x13, 0x94, 0x4b,
+ 0x1c, 0x43, 0x0c, 0xe1, 0xeb, 0x91, 0x96, 0xd6,
+ 0xb0, 0xc6, 0x1e, 0xf2, 0x3b, 0x25, 0x7a, 0x5a,
+ 0xc7, 0xfb, 0x42, 0xbb, 0xf5, 0x60, 0x25, 0x1f,
+ 0xb6, 0x93, 0xbf, 0x4f, 0xc2, 0x53, 0x0a, 0xa0,
+ 0xb9, 0x6e, 0x24, 0x8e, 0xfd, 0x30, 0x0b, 0x7c,
+ 0xf4, 0xc2, 0xd9, 0x3d, 0xb1, 0x18, 0xfe, 0xa6,
+ 0xea, 0x79, 0xfb, 0xfb, 0x96, 0x7e, 0xcc, 0xc7,
+ 0xf3, 0x22, 0xbb, 0x69, 0x48, 0xab, 0x9d, 0xf7,
+ 0x03, 0xad, 0x2a, 0xc4, 0x41, 0x36, 0xc0, 0xab,
+ 0x15, 0x08, 0x24, 0x22, 0x61, 0x16, 0x7b, 0x26,
+ 0x2c, 0xa4, 0x10, 0x98, 0x4d, 0xd3, 0x16, 0x01,
+ 0x97, 0xcc, 0x7e, 0xe7, 0x56, 0x81, 0x14, 0x7b,
+ 0x9a, 0x4e, 0x75, 0x4e, 0x11, 0x4f, 0xcb, 0xd0,
+ 0xc7, 0x02, 0x21, 0x13, 0xdb, 0x3c, 0x2c, 0x27,
+ 0x98, 0x23, 0x81, 0x86, 0x00, 0xe0, 0x73, 0xee,
+ 0xe0, 0x8c, 0xfd, 0xa1, 0x75, 0xbe, 0xe1, 0x11,
+ 0x8f, 0xf3, 0x1f, 0x73, 0xfc, 0xc7, 0xde, 0xa0,
+ 0x82, 0x03, 0x2f, 0xcc, 0x65, 0xbb, 0xaf, 0x63,
+ 0x3a, 0xb8, 0x72, 0x1b, 0x7b, 0x3e, 0x73, 0xd8,
+ 0x07, 0x80, 0xba, 0x90, 0xc3, 0x40, 0xa8, 0x88,
+ 0xd9, 0xe2, 0xfa, 0x17, 0x7d, 0xcc, 0x05, 0xb7,
+ 0xfb, 0xeb, 0x77, 0xdc, 0x30, 0x50, 0x3f, 0xc0,
+ 0x77, 0x3e, 0xea, 0x0d, 0xb7, 0xf7, 0xac, 0x75,
+ 0xee, 0x00, 0x90, 0x21, 0xf0, 0x15, 0x3c, 0x26,
+ 0x7d, 0xcb, 0x09, 0x88, 0x67, 0x88, 0x70, 0x5d,
+ 0xb1, 0x4a, 0x56, 0xdf, 0xb6, 0x2d, 0xdb, 0x11,
+ 0xe5, 0x40, 0xfb, 0x49, 0xdd, 0x8e, 0x84, 0x19,
+ 0x2a, 0x80, 0x83, 0xfb, 0x54, 0x3b, 0xf8, 0xda,
+ 0x5a, 0x77, 0x14, 0x86, 0x3e, 0x99, 0x34, 0x8a,
+ 0x74, 0x47, 0x69, 0x9a, 0x2b, 0x0a, 0x6c, 0x8e,
+ 0xc7, 0x0d, 0xe3, 0x11, 0xf3, 0x74, 0x26, 0x68,
+ 0x93, 0x40, 0x19, 0x77, 0x62, 0x62, 0xda, 0xe3,
+ 0x04, 0xbb, 0x64, 0x6a, 0x5c, 0xa7, 0xf3, 0x0a,
+ 0x63, 0x28, 0x26, 0x5f, 0x98, 0x14, 0x83, 0xd2,
+ 0xeb, 0x67, 0xac, 0x79, 0x42, 0xae, 0xae, 0x16,
+ 0xfe, 0xb1, 0x09, 0x87, 0xff, 0x01, 0x63, 0x84,
+ 0x18, 0x9c, 0x3b, 0x9c, 0x67, 0x0d, 0xff, 0x01,
+ 0x96, 0xb0, 0xc8, 0x20, 0x91, 0x88, 0x48, 0x3e,
+ 0x77, 0x86, 0xef, 0x9c, 0xfd, 0xcb, 0x4d, 0x02,
+ 0x6e, 0x8c, 0x80, 0x48, 0x2b, 0x0e, 0x76, 0xe8,
+ 0xc1, 0x04, 0x2b, 0xe5, 0xff, 0x6e, 0xfe, 0x60,
+ 0x9a, 0x7e, 0x55, 0xf2, 0x0f, 0x95, 0x29, 0xbb,
+ 0xf3, 0x02, 0x2a, 0xf9, 0x58, 0xdd, 0x3e, 0x47,
+ 0xc6, 0xe8, 0x90, 0x85, 0x73, 0xcc, 0x1b, 0x29,
+ 0xd7, 0xe2, 0x4f, 0x60, 0x18, 0x06, 0x98, 0xcb,
+ 0x18, 0xb6, 0x89, 0x01, 0x69, 0x8e, 0x38, 0x42,
+ 0xbf, 0x72, 0x52, 0xdf, 0x6c, 0x7c, 0xb7, 0xf6,
+ 0x6f, 0x61, 0xa1, 0x58, 0x82, 0xa7, 0xfc, 0x26,
+ 0x1a, 0x10, 0x88, 0xb7, 0xf6, 0x07, 0x61, 0xf3,
+ 0x88, 0x88, 0x3e, 0xcf, 0x22, 0xde, 0xe7, 0x79,
+ 0x8e, 0x00, 0x63, 0x7c, 0x9c, 0xea, 0x9b, 0x7c,
+ 0x0b, 0x22, 0x0f, 0x06, 0x9c, 0xa2, 0x1b, 0xa6,
+ 0x20, 0x95, 0x08, 0x1a, 0x73, 0xc6, 0x06, 0x68,
+ 0x09, 0x01, 0x9e, 0x09, 0xc1, 0x61, 0x81, 0x90,
+ 0x1c, 0x8e, 0x91, 0x00, 0x03, 0x0f, 0x79, 0xcc,
+ 0xcd, 0xfe, 0x40, 0xb2, 0xc8, 0x14, 0x04, 0x5f,
+ 0xd1, 0x49, 0x4c, 0xce, 0x0a, 0x65, 0x54, 0x11,
+ 0x16, 0xfb, 0xc1, 0x4c, 0x3d, 0xb1, 0x11, 0x6f,
+ 0x71, 0x88, 0xb9, 0xdc, 0x49, 0x96, 0xfc, 0xe3,
+ 0xed, 0x93, 0x4d, 0x31, 0x07, 0xcc, 0xfe, 0xcb,
+ 0xe0, 0xe5, 0x31, 0xfc, 0xb3, 0xec, 0x3f, 0x2c,
+ 0xdb, 0x77, 0x56, 0xc4, 0xdf, 0x01, 0xd1, 0x31,
+ 0xe6, 0x1c, 0xa7, 0xde, 0x61, 0x53, 0x1e, 0x0e,
+ 0xc6, 0x77, 0xe5, 0xb2, 0xba, 0x47, 0xcc, 0x26,
+ 0x43, 0xaa, 0x9f, 0x81, 0xa7, 0x2b, 0xe3, 0x32,
+ 0x1d, 0x45, 0x3c, 0xef, 0xbc, 0x55, 0x21, 0x44,
+ 0x4f, 0x4e, 0x5b, 0x52, 0x43, 0x14, 0x82, 0xbf,
+ 0xa2, 0x36, 0xd3, 0xcf, 0x9c, 0xdc, 0xe9, 0xfe,
+ 0x72, 0x32, 0x45, 0x80, 0x46, 0x5e, 0xad, 0x9b,
+ 0xa7, 0x66, 0xca, 0xf7, 0xcb, 0x62, 0x19, 0x7e,
+ 0x1f, 0xec, 0x3f, 0x87, 0xfb, 0x77, 0x35, 0x52,
+ 0x15, 0xf8, 0x06, 0x94, 0x50, 0x20, 0x0d, 0x30,
+ 0x7f, 0x31, 0x94, 0x1d, 0x4e, 0x53, 0xca, 0x12,
+ 0x16, 0xcd, 0x64, 0x45, 0xbd, 0x45, 0x83, 0x94,
+ 0x7f, 0x00, 0x41, 0xf0, 0xa6, 0x90, 0x72, 0x8b,
+ 0x4c, 0x97, 0xa8, 0x1b, 0x94, 0xd2, 0x0c, 0x15,
+ 0x00, 0x52, 0x19, 0x10, 0x23, 0x5e, 0x57, 0x3c,
+ 0x64, 0x81, 0x96, 0x03, 0x85, 0x7b, 0xf4, 0xb2,
+ 0x5b, 0xea, 0xf5, 0x57, 0xdf, 0x51, 0x90, 0xb7,
+ 0x5c, 0xa2, 0x77, 0xce, 0xa0, 0xd9, 0xae, 0x1e,
+ 0xd2, 0x0a, 0x9e, 0xa0, 0xa7, 0xfa, 0x69, 0x73,
+ 0x84, 0x08, 0x99, 0x24, 0xf2, 0x32, 0x8a, 0x8e,
+ 0x5c, 0xa6, 0xe8, 0x95, 0x3b, 0xaa, 0x38, 0xd8,
+ 0xb4, 0x31, 0xb6, 0xff, 0xd6, 0x5d, 0xde, 0xa0,
+ 0x06, 0x6c, 0x82, 0x69, 0x5d, 0xf2, 0x12, 0x52,
+ 0x0d, 0x01, 0x1d, 0xc3, 0x46, 0xfa, 0x77, 0xad,
+ 0xb8, 0x5d, 0xe8, 0xdc, 0x17, 0x7a, 0x35, 0x00,
+ 0xb6, 0x90, 0xc2, 0x73, 0xb5, 0xf0, 0xd7, 0x28,
+ 0xf4, 0x22, 0x0b, 0x59, 0x0d, 0x8e, 0xb1, 0x03,
+ 0x63, 0x80, 0x89, 0x1a, 0x6a, 0xbe, 0x62, 0x08,
+ 0xcf, 0x01, 0x9e, 0x35, 0x82, 0x68, 0xad, 0xe8,
+ 0x5d, 0x4c, 0x5c, 0x91, 0x2b, 0x0d, 0x4b, 0x44,
+ 0xd3, 0x42, 0x20, 0x31, 0x58, 0x7d, 0x64, 0x11,
+ 0x73, 0x03, 0x66, 0xfc, 0x00, 0xcb, 0x20, 0x10,
+ 0x3a, 0x7f, 0x4d, 0x4e, 0xf4, 0x48, 0x33, 0x46,
+ 0x5a, 0xc4, 0xc7, 0x60, 0xb6, 0x10, 0x50, 0x54,
+ 0x2e, 0x46, 0x58, 0x5b, 0x81, 0x9a, 0x41, 0xc1,
+ 0x64, 0xb0, 0x03, 0x1c, 0x29, 0xe4, 0x42, 0xcf,
+ 0xae, 0x89, 0x87, 0x93, 0x00, 0x20, 0xa7, 0x12,
+ 0xdd, 0xe7, 0x4a, 0x12, 0xcf, 0xf3, 0x19, 0xde,
+ 0x9b, 0xbf, 0x45, 0xa6, 0xeb, 0x9c, 0x32, 0x1a,
+ 0x92, 0xdc, 0x6f, 0x85, 0x9f, 0x05, 0x09, 0x2c,
+ 0xa7, 0xd1, 0xda, 0x31, 0x72, 0x96, 0xdf, 0xea,
+ 0xa9, 0xcf, 0xbf, 0x26, 0x2c, 0x82, 0x08, 0x58,
+ 0x7c, 0x02, 0xf6, 0xdb, 0xa9, 0x2d, 0x92, 0xa5,
+ 0x69, 0x77, 0x97, 0x68, 0x59, 0xbb, 0x2a, 0xe2,
+ 0xd8, 0x1a, 0x84, 0x2a, 0xa0, 0x5f, 0x72, 0x97,
+ 0x08, 0x08, 0x25, 0xce, 0x17, 0x53, 0x9c, 0x3e,
+ 0x40, 0xe7, 0x2e, 0x6c, 0xb7, 0xc2, 0x40, 0x65,
+ 0xb5, 0x58, 0x09, 0x47, 0x66, 0x74, 0xcd, 0x06,
+ 0xa1, 0x94, 0xf2, 0xa0, 0x8c, 0xd0, 0x07, 0x09,
+ 0x6d, 0x65, 0xc8, 0x5a, 0x78, 0xc4, 0x00, 0x5a,
+ 0x60, 0x6a, 0x03, 0xed, 0x14, 0x01, 0x93, 0x06,
+ 0x20, 0x40, 0xb4, 0xe0, 0xda, 0x69, 0xc3, 0x56,
+ 0x3e, 0x24, 0x91, 0xd7, 0x8c, 0x26, 0x62, 0xfe,
+ 0x68, 0x4f, 0xa8, 0xac, 0x06, 0xe8, 0x5b, 0x84,
+ 0x82, 0x04, 0xe2, 0x6d, 0xaa, 0x29, 0x08, 0x31,
+ 0x8c, 0xc2, 0x08, 0x03, 0x8d, 0xb3, 0x2e, 0x72,
+ 0x62, 0x32, 0x99, 0xe1, 0xd8, 0x00, 0xa8, 0x4d,
+ 0x91, 0x8b, 0xf6, 0x69, 0x74, 0x3c, 0xc8, 0x4c,
+ 0x04, 0x02, 0xe8, 0x0e, 0x01, 0xb6, 0x9e, 0x84,
+ 0x3a, 0x80, 0x90, 0x18, 0xe0, 0xd8, 0x16, 0xcf,
+ 0xd7, 0x24, 0xfa, 0xbe, 0xe7, 0x3e, 0xf6, 0xa9,
+ 0x5d, 0xe3, 0xa2, 0x17, 0x3d, 0xe7, 0x04, 0x82,
+ 0x43, 0x47, 0x63, 0xc8, 0xae, 0x9d, 0x67, 0x62,
+ 0x10, 0xa8, 0x16, 0x89, 0xd2, 0x09, 0x20, 0x63,
+ 0x93, 0xf8, 0xcc, 0x07, 0xbf, 0x26, 0x03, 0x71,
+ 0xd2, 0x30, 0x80, 0x20, 0xfc, 0xa0, 0x4e, 0xe2,
+ 0x44, 0x17, 0x09, 0x27, 0x85, 0x9e, 0x08, 0x40,
+ 0x65, 0xf9, 0x9f, 0xdb, 0x3e, 0x67, 0xf6, 0x5b,
+ 0x64, 0x15, 0x8f, 0xed, 0xdf, 0x64, 0xfb, 0x76,
+ 0x9c, 0xfe, 0xe7, 0x36, 0xde, 0x03, 0xc4, 0x83,
+ 0xb7, 0xe6, 0x73, 0xfa, 0x00, 0x5c, 0x22, 0x12,
+ 0x52, 0x08, 0x5b, 0x89, 0x90, 0xcb, 0x0a, 0x00,
+ 0x33, 0xf9, 0x82, 0x2c, 0xdd, 0xed, 0x63, 0x27,
+ 0xf6, 0x44, 0x5b, 0xde, 0x40, 0x9d, 0xd7, 0x48,
+ 0x0e, 0x5f, 0xc1, 0x2b, 0x9c, 0x10, 0x52, 0xdb,
+ 0x1f, 0xf5, 0x85, 0x18, 0xe2, 0x14, 0x07, 0x38,
+ 0x5b, 0x05, 0xd2, 0x3b, 0xa3, 0x0a, 0xd8, 0x50,
+ 0xd8, 0xf1, 0xb4, 0x77, 0x3d, 0x7e, 0x84, 0xee,
+ 0x5b, 0x5f, 0x20, 0xa4, 0x4a, 0x9a, 0x20, 0x34,
+ 0x07, 0x68, 0x33, 0x01, 0x8a, 0xf4, 0xc0, 0x20,
+ 0x89, 0x20, 0x0a, 0xe0, 0x74, 0x02, 0x08, 0x60,
+ 0xa1, 0x6e, 0x7a, 0x86, 0x6e, 0x84, 0xbc, 0xc8,
+ 0x21, 0x2f, 0xf0, 0xa8, 0x4b, 0xa8, 0xc2, 0x19,
+ 0x92, 0x20, 0x84, 0x1f, 0xd9, 0x21, 0x06, 0x93,
+ 0x08, 0x18, 0x0c, 0xba, 0x45, 0xc5, 0x0a, 0x85,
+ 0x7f, 0x5b, 0x7d, 0xc0, 0x23, 0xb8, 0x57, 0x1d,
+ 0xbe, 0xa0, 0xe0, 0x65, 0xe1, 0x38, 0x02, 0xbf,
+ 0xf2, 0x42, 0x08, 0x5a, 0x69, 0xbf, 0xfb, 0xaa,
+ 0x75, 0x85, 0xbf, 0xd8, 0x61, 0x6e, 0xf3, 0xa8,
+ 0x62, 0x94, 0xa2, 0x74, 0xae, 0x2d, 0xe1, 0x38,
+ 0x5b, 0x21, 0x56, 0xc2, 0x9a, 0x6a, 0x81, 0xa6,
+ 0x05, 0x40, 0x6d, 0x9c, 0xb0, 0x8e, 0xe6, 0x9e,
+ 0x36, 0x9c, 0x70, 0x09, 0xa7, 0xf9, 0x0f, 0x29,
+ 0x80, 0xe8, 0xc2, 0xab, 0x6f, 0x42, 0x89, 0xc5,
+ 0x91, 0xcf, 0x1b, 0xc4, 0x65, 0x9e, 0x90, 0x1c,
+ 0xf7, 0xb4, 0x46, 0x1a, 0x96, 0x1c, 0x82, 0x87,
+ 0x30, 0x2d, 0xa5, 0x30, 0x8c, 0x31, 0x1c, 0x36,
+ 0xc9, 0x87, 0x94, 0x9b, 0xf0, 0x23, 0x26, 0xa3,
+ 0x68, 0x1e, 0x26, 0x7c, 0x66, 0x99, 0x99, 0x89,
+ 0xf2, 0xa6, 0xa5, 0x73, 0x84, 0x10, 0x1a, 0x69,
+ 0x20, 0x12, 0x2f, 0xe8, 0x05, 0xbc, 0xd7, 0x20,
+ 0x70, 0x16, 0xc3, 0x00, 0x84, 0x1c, 0x29, 0x09,
+ 0x35, 0x1e, 0x06, 0xe7, 0x06, 0x20, 0x37, 0x7f,
+ 0x14, 0x24, 0x5f, 0xe0, 0x8b, 0x77, 0xeb, 0x42,
+ 0x15, 0xd4, 0x01, 0x98, 0x08, 0x07, 0xf0, 0x2a,
+ 0x00, 0x54, 0xb6, 0xd2, 0x65, 0x54, 0x40, 0x85,
+ 0x7e, 0x18, 0x8c, 0xbe, 0x54, 0x20, 0x57, 0xdf,
+ 0x88, 0xcb, 0xe4, 0x62, 0xb2, 0x40, 0xb0, 0x4e,
+ 0x9b, 0xc4, 0x03, 0x4c, 0x1b, 0x82, 0x15, 0xf8,
+ 0x50, 0xb8, 0x4b, 0xac, 0x6c, 0xdb, 0xd0, 0x12,
+ 0xe7, 0xb5, 0x2a, 0xc9, 0xa8, 0x51, 0xb9, 0x6e,
+ 0xb8, 0x01, 0x54, 0xbb, 0x2b, 0x36, 0xe8, 0x84,
+ 0xcd, 0x4b, 0xf2, 0x85, 0x5f, 0x48, 0x8e, 0x11,
+ 0x46, 0x09, 0x47, 0x97, 0x62, 0xd3, 0x1c, 0xb3,
+ 0x38, 0x48, 0x14, 0x65, 0xb1, 0xe9, 0x33, 0x6e,
+ 0xc8, 0x70, 0x41, 0xb3, 0xa6, 0xb4, 0xf9, 0x02,
+ 0x2d, 0xfd, 0x86, 0x21, 0xec, 0x26, 0xc0, 0xc7,
+ 0x53, 0xf1, 0xb6, 0xc2, 0x21, 0x4e, 0x1a, 0xfe,
+ 0x31, 0xdd, 0xcd, 0xc4, 0xd3, 0xe2, 0xc3, 0xb0,
+ 0xf7, 0x0d, 0x6e, 0x70, 0x03, 0x0b, 0x79, 0x9a,
+ 0x32, 0x28, 0x29, 0xfd, 0x5f, 0x19, 0xe0, 0x3a,
+ 0x63, 0xbc, 0xe7, 0x24, 0xa3, 0xec, 0x7f, 0x61,
+ 0xfb, 0x1b, 0x9b, 0x73, 0x26, 0x53, 0xb8, 0x57,
+ 0x0d, 0x93, 0x95, 0xc0, 0x20, 0x8b, 0xa0, 0x9a,
+ 0x7d, 0x8f, 0x75, 0xb3, 0x75, 0x7d, 0x00, 0xc7,
+ 0x0b, 0x46, 0xb1, 0xf6, 0xc5, 0x4d, 0x30, 0xdd,
+ 0x38, 0x57, 0xcf, 0xfe, 0xe7, 0x2d, 0x61, 0x15,
+ 0x44, 0x08, 0x45, 0x55, 0xfe, 0x49, 0x06, 0xd5,
+ 0x40, 0xc7, 0x00, 0x61, 0x9d, 0xc6, 0xf4, 0x6f,
+ 0x1c, 0xcb, 0x52, 0xdf, 0xe0, 0x4e, 0x5b, 0xf6,
+ 0xc5, 0x15, 0x8c, 0x7e, 0xd5, 0xf7, 0x3f, 0xb5,
+ 0x7c, 0x82, 0x08, 0xaa, 0x69, 0xfb, 0xb8, 0xc2,
+ 0xbe, 0xee, 0x87, 0x0c, 0x78, 0x04, 0x83, 0xee,
+ 0xff, 0x2d, 0xfb, 0xbf, 0xdb, 0xbd, 0xc3, 0xf7,
+ 0x3f, 0xbb, 0xc1, 0xcc, 0xee, 0x61, 0x8f, 0xe0,
+ 0x42, 0xbd, 0xd2, 0x86, 0x4c, 0xc0, 0x14, 0xca,
+ 0x5c, 0x66, 0x3f, 0xb2, 0xb8, 0x0a, 0x73, 0x05,
+ 0xf7, 0x5c, 0xc1, 0x31, 0xbc, 0xdc, 0x6c, 0x85,
+ 0x68, 0x19, 0x27, 0x5c, 0x06, 0x98, 0x4b, 0x85,
+ 0xa7, 0x30, 0xa1, 0x0a, 0xb7, 0xc8, 0x5b, 0xe4,
+ 0xc6, 0x06, 0xef, 0xf5, 0x05, 0x86, 0x21, 0xc0,
+ 0x6f, 0xff, 0x98, 0x5c, 0x3f, 0xc2, 0xa2, 0x08,
+ 0x16, 0x81, 0x6e, 0xc3, 0xc5, 0x53, 0xae, 0x5a,
+ 0x93, 0xc9, 0xe5, 0x0c, 0xbe, 0x5c, 0xba, 0x00,
+ 0x60, 0x6c, 0x37, 0xc4, 0x08, 0x0d, 0x26, 0xe8,
+ 0x85, 0x81, 0x9a, 0x7a, 0xa1, 0x20, 0xd2, 0x90,
+ 0x1a, 0x68, 0xe6, 0x07, 0x48, 0x1b, 0x81, 0x8e,
+ 0x01, 0xc2, 0x65, 0x85, 0x08, 0x48, 0x2e, 0xda,
+ 0x16, 0x1f, 0xc9, 0xc4, 0x2b, 0x46, 0x65, 0x73,
+ 0xa6, 0x19, 0x98, 0xe5, 0xda, 0x06, 0x53, 0x34,
+ 0x22, 0x00, 0xcb, 0x04, 0x40, 0x1d, 0x4e, 0x0c,
+ 0x0c, 0x74, 0x8c, 0x23, 0x2f, 0xfc, 0xc6, 0xd3,
+ 0x50, 0x53, 0x1d, 0x52, 0x34, 0x65, 0x1a, 0xf7,
+ 0x6b, 0x97, 0xc7, 0xc4, 0xe7, 0x1b, 0x50, 0x39,
+ 0x4b, 0x14, 0x0c, 0x70, 0x2d, 0x2b, 0x24, 0x7e,
+ 0xc6, 0x81, 0xc6, 0xf2, 0x32, 0xcd, 0x2c, 0x4e,
+ 0x5f, 0xdb, 0x73, 0x4e, 0xac, 0xda, 0xc9, 0x1c,
+ 0x81, 0x90, 0xd8, 0x9c, 0x2c, 0xb4, 0x45, 0x0b,
+ 0x1f, 0x48, 0x14, 0xe7, 0xf5, 0xd4, 0x31, 0x1e,
+ 0x71, 0x48, 0x16, 0x3c, 0x44, 0x81, 0xcb, 0xeb,
+ 0x81, 0x70, 0x83, 0x10, 0x1b, 0x3e, 0x0a, 0x10,
+ 0xaf, 0xb5, 0x11, 0x92, 0x4e, 0xe3, 0x40, 0xfc,
+ 0x69, 0xd9, 0x24, 0xce, 0x32, 0x1f, 0xd8, 0x74,
+ 0xcb, 0xf5, 0xe3, 0x32, 0x81, 0x00, 0x1a, 0x25,
+ 0xde, 0x13, 0xaf, 0xd6, 0x4d, 0xdf, 0xf5, 0x8d,
+ 0x77, 0xfa, 0xe7, 0x8d, 0x3e, 0xb6, 0x33, 0x4f,
+ 0xd6, 0x69, 0xc7, 0xeb, 0x0d, 0x71, 0xf8, 0x47,
+ 0x98, 0xf1, 0x24, 0x10, 0xaf, 0x32, 0x15, 0xc3,
+ 0xe1, 0x10, 0x40, 0xf8, 0x4b, 0x08, 0x7d, 0x75,
+ 0xd7, 0x0a, 0x2c, 0x00, 0x2b, 0xf5, 0x84, 0x20,
+ 0x83, 0xb8, 0x4e, 0xa3, 0x28, 0x06, 0x18, 0x11,
+ 0x84, 0x2b, 0xc4, 0x43, 0x2d, 0xff, 0x20, 0x48,
+ 0x3c, 0x3c, 0xe6, 0x18, 0x7d, 0x08, 0xa7, 0xf9,
+ 0xa1, 0x70, 0xff, 0x18, 0x4f, 0x62, 0xc8, 0x16,
+ 0x1f, 0xe8, 0x09, 0x8f, 0xf7, 0xc4, 0x3d, 0x83,
+ 0x88, 0xc2, 0xbc, 0x2a, 0x52, 0xdf, 0xe0, 0x11,
+ 0x86, 0x19, 0x02, 0x69, 0xc6, 0x83, 0x58, 0xff,
+ 0x81, 0x67, 0x3f, 0xe0, 0x15, 0x8c, 0xd8, 0x72,
+ 0xfb, 0x20, 0xcc, 0x20, 0xc2, 0x46, 0x3f, 0xc8,
+ 0x2c, 0x83, 0xfa, 0x10, 0x3f, 0x37, 0x1d, 0x7e,
+ 0x7a, 0x12, 0x8c, 0x33, 0xb5, 0x9a, 0x0a, 0x20,
+ 0x67, 0xfa, 0x92, 0x99, 0xfe, 0x54, 0x53, 0x01,
+ 0xec, 0x07, 0x86, 0xd3, 0x02, 0x80, 0x16, 0xfc,
+ 0x6e, 0x45, 0x3d, 0xf9, 0x03, 0x24, 0x2f, 0xc2,
+ 0x65, 0x0b, 0xa1, 0x14, 0x46, 0x60, 0x04, 0x06,
+ 0x3f, 0xfe, 0x08, 0x83, 0xff, 0x02, 0x29, 0xfd,
+ 0xa4, 0x0b, 0x7e, 0xc0, 0x22, 0x8f, 0xed, 0x0d,
+ 0x87, 0xe2, 0xa3, 0x20, 0xfe, 0xc8, 0x8b, 0x60,
+ 0x90, 0x14, 0x08, 0x1b, 0x8c, 0xaf, 0xfb, 0xc6,
+ 0x61, 0x80, 0xf0, 0x49, 0xff, 0x74, 0xe7, 0x3f,
+ 0x4c, 0x10, 0x2a, 0xa2, 0xe4, 0x63, 0xfb, 0x8f,
+ 0xca, 0x3e, 0xe3, 0xf7, 0x2f, 0xb8, 0xf0, 0xb7,
+ 0xee, 0x3f, 0x70, 0xfb, 0x89, 0x5a, 0x72, 0xba,
+ 0x22, 0xde, 0xfd, 0x89, 0xef, 0x2a, 0x25, 0x32,
+ 0x1d, 0x6b, 0xf4, 0xcf, 0xa0, 0xad, 0x79, 0x94,
+ 0xfb, 0xba, 0xc9, 0x61, 0xef, 0x21, 0x1d, 0x3f,
+ 0xcc, 0x64, 0x08, 0xbe, 0x0d, 0xa7, 0x22, 0xc3,
+ 0x2a, 0xa7, 0x58, 0x4a, 0x3d, 0xfa, 0x52, 0x9f,
+ 0xe1, 0xa1, 0xcf, 0xe0, 0x27, 0x65, 0xe0, 0xa9,
+ 0xd8, 0xfb, 0x0e, 0x37, 0x3e, 0x87, 0x31, 0x43,
+ 0xab, 0x01, 0x3a, 0xf5, 0x71, 0x4c, 0xa1, 0xb2,
+ 0x33, 0x1a, 0xc4, 0x0d, 0xce, 0x40, 0x23, 0x67,
+ 0xdb, 0xa4, 0x58, 0xfa, 0x58, 0x22, 0x9f, 0x02,
+ 0x41, 0x03, 0xac, 0x06, 0x20, 0x87, 0x40, 0x1d,
+ 0xa4, 0x3e, 0x07, 0x5f, 0xaf, 0x09, 0xcf, 0xac,
+ 0x74, 0x67, 0xe7, 0xd9, 0x48, 0x7e, 0xc1, 0xc3,
+ 0x4d, 0xba, 0x89, 0x43, 0xeb, 0xef, 0x34, 0xfb,
+ 0x2d, 0xdd, 0xbf, 0x12, 0x32, 0x9e, 0xb4, 0x41,
+ 0xc7, 0xec, 0x7f, 0x0a, 0xfe, 0x64, 0x08, 0x7d,
+ 0x85, 0xc3, 0x2f, 0xb1, 0x50, 0xcb, 0xec, 0x5f,
+ 0x63, 0xe6, 0x53, 0x9d, 0xfd, 0x8b, 0xf0, 0xaf,
+ 0xe6, 0x40, 0x87, 0xc4, 0x9c, 0x62, 0xf6, 0x2c,
+ 0xcc, 0x7d, 0x8b, 0xf6, 0x3e, 0x16, 0xb9, 0x8f,
+ 0xc5, 0x1f, 0x0a, 0xfe, 0x64, 0x08, 0x7b, 0x0e,
+ 0xb7, 0x08, 0xc5, 0x19, 0x93, 0x0b, 0x09, 0x5b,
+ 0xc3, 0xcf, 0xd1, 0x70, 0xf3, 0xc7, 0x3d, 0x4f,
+ 0x01, 0xa7, 0x0d, 0xa1, 0x63, 0x9a, 0xc9, 0x08,
+ 0x30, 0xf9, 0xf6, 0x2c, 0x3e, 0x19, 0xcf, 0xf8,
+ 0xe3, 0x0a, 0xd3, 0x12, 0xd8, 0xe4, 0x9c, 0x36,
+ 0x3d, 0x27, 0xa9, 0x88, 0xeb, 0xb1, 0xa0, 0x32,
+ 0xc0, 0xe8, 0x25, 0xba, 0x51, 0x13, 0x7f, 0xfb,
+ 0x4c, 0x14, 0x33, 0xc9, 0xb0, 0x5b, 0xe2, 0x3a,
+ 0x66, 0x9b, 0x69, 0x81, 0x8b, 0xfd, 0x81, 0x3a,
+ 0x82, 0x48, 0xd8, 0xe4, 0x14, 0x22, 0x0b, 0x98,
+ 0x04, 0xea, 0xe5, 0xe6, 0x63, 0xff, 0x70, 0xca,
+ 0x60, 0x32, 0x07, 0x91, 0xec, 0x6d, 0x40, 0x5d,
+ 0xfe, 0x02, 0x33, 0xe0, 0x84, 0x2b, 0xb8, 0x4a,
+ 0x31, 0x6f, 0xf3, 0x0c, 0xc7, 0xfc, 0x41, 0x99,
+ 0x6f, 0xe0, 0xe5, 0x3f, 0xcc, 0x5b, 0x9f, 0xf3,
+ 0x0e, 0x7e, 0x65, 0x36, 0xe6, 0x98, 0x0f, 0x3f,
+ 0x9b, 0x5b, 0x36, 0x9d, 0x06, 0x41, 0xbc, 0xd3,
+ 0x31, 0xfd, 0xe8, 0x66, 0x03, 0xde, 0x20, 0x18,
+ 0xb7, 0xe7, 0x04, 0x20, 0xfb, 0x42, 0x9b, 0x3f,
+ 0xe0, 0x12, 0x9f, 0xb5, 0x15, 0x8b, 0xfc, 0x24,
+ 0x67, 0xfb, 0x4a, 0xd8, 0xbf, 0x98, 0x66, 0xcf,
+ 0xe3, 0x04, 0xcb, 0xed, 0x4f, 0x62, 0xfd, 0x69,
+ 0x1c, 0xfe, 0x6a, 0x76, 0x7f, 0xcc, 0x10, 0x83,
+ 0xe0, 0x6a, 0x70, 0xc8, 0xd0, 0x4a, 0x7f, 0x36,
+ 0x82, 0x0c, 0x83, 0x19, 0x77, 0xf3, 0x4a, 0x20,
+ 0xd7, 0xe8, 0x1c, 0x31, 0xe4, 0x16, 0xcf, 0xcc,
+ 0xad, 0xf6, 0xc2, 0xa0, 0x74, 0x98, 0x28, 0x1d,
+ 0x2b, 0xd4, 0x26, 0xdf, 0xe0, 0x9d, 0xcf, 0xf8,
+ 0x26, 0x0a, 0xf9, 0x90, 0x9d, 0x3f, 0xc6, 0x53,
+ 0xef, 0xa8, 0xa4, 0x2b, 0x24, 0x06, 0x62, 0xfb,
+ 0xb3, 0x4a, 0x60, 0x46, 0x13, 0x09, 0x1c, 0x01,
+ 0xbc, 0xed, 0x2a, 0xf0, 0xb6, 0xff, 0x31, 0x21,
+ 0x58, 0xfb, 0x2b, 0x6f, 0xee, 0x0c, 0xc7, 0x04,
+ 0x81, 0x9d, 0xc9, 0x08, 0xa5, 0xbf, 0x60, 0x21,
+ 0x96, 0x98, 0xdc, 0xdb, 0xf8, 0x91, 0x33, 0xfe,
+ 0xf4, 0xa7, 0xf1, 0x60, 0x13, 0x4d, 0x8a, 0xc0,
+ 0xcd, 0x23, 0x34, 0xb1, 0xf6, 0x74, 0xa4, 0x12,
+ 0x2a, 0x49, 0x17, 0xf1, 0x12, 0xc7, 0xf5, 0xc2,
+ 0x05, 0x55, 0xdc, 0x61, 0x52, 0xae, 0x31, 0x6f,
+ 0xbc, 0x48, 0xe7, 0xa7, 0x61, 0x9d, 0x67, 0xbd,
+ 0x0e, 0x70, 0xbe, 0x11, 0x80, 0xf2, 0x1a, 0x60,
+ 0x62, 0x8e, 0xb0, 0xdb, 0xa3, 0x52, 0x06, 0x49,
+ 0x03, 0x01, 0xbe, 0x15, 0x00, 0x74, 0x34, 0xfc,
+ 0xc0, 0x04, 0x10, 0xa1, 0x1b, 0x34, 0x6f, 0x40,
+ 0x41, 0xfb, 0xe3, 0x11, 0x7f, 0x40, 0xa7, 0xbf,
+ 0x6b, 0x13, 0xa6, 0x6d, 0x0c, 0xcd, 0xf3, 0x13,
+ 0x32, 0x9e, 0x21, 0xf0, 0x16, 0x5f, 0xc4, 0x0d,
+ 0xb7, 0xd8, 0x42, 0x6d, 0xe9, 0xf1, 0x08, 0x20,
+ 0xb2, 0x36, 0xff, 0x6f, 0x88, 0xbf, 0x3f, 0xe0,
+ 0x2b, 0x99, 0x80, 0x58, 0xec, 0xa4, 0x22, 0x08,
+ 0x62, 0x85, 0xce, 0x76, 0xc2, 0x74, 0xcb, 0x5a,
+ 0x98, 0xbb, 0x5e, 0x43, 0x0c, 0x0a, 0x01, 0xa6,
+ 0xa6, 0x60, 0x73, 0x81, 0x00, 0x98, 0x6a, 0x5e,
+ 0x06, 0xf8, 0x2f, 0x01, 0xd2, 0x26, 0x47, 0x6f,
+ 0x86, 0xd8, 0x08, 0x23, 0xf0, 0x02, 0x08, 0x40,
+ 0x01, 0xb6, 0x24, 0x60, 0x79, 0xfb, 0x71, 0x5d,
+ 0x32, 0xca, 0xa6, 0x2e, 0x5b, 0x85, 0xcf, 0xfd,
+ 0x52, 0x6c, 0xe4, 0x70, 0x59, 0x7e, 0xb8, 0x87,
+ 0x3f, 0xe3, 0x2d, 0x9f, 0xa6, 0x48, 0x3e, 0xf9,
+ 0x0a, 0xd9, 0xfb, 0x02, 0x57, 0x38, 0xb3, 0x89,
+ 0xca, 0x8d, 0xa0, 0x69, 0x98, 0x18, 0x58, 0x7e,
+ 0xeb, 0xf3, 0xee, 0xfc, 0x1d, 0x97, 0xce, 0xe8,
+ 0x65, 0x80, 0x48, 0x1e, 0xe8, 0xb0, 0x16, 0x1b,
+ 0x38, 0x89, 0xd7, 0x0c, 0xeb, 0x75, 0xf9, 0xea,
+ 0x5a, 0x7c, 0xa2, 0x40, 0xaf, 0xf6, 0x29, 0x97,
+ 0xb8, 0x06, 0x63, 0xfe, 0x11, 0x1d, 0x3e, 0xc4,
+ 0xe7, 0x58, 0x31, 0x81, 0xbf, 0xaf, 0xa0, 0x0a,
+ 0xc5, 0x41, 0x9e, 0xf7, 0xae, 0xa2, 0xdf, 0xc7,
+ 0x95, 0xf7, 0xd2, 0xaf, 0x0a, 0xbf, 0x7a, 0xd8,
+ 0xfa, 0xbc, 0x76, 0x3f, 0x48, 0x00, 0x83, 0xea,
+ 0xd5, 0x74, 0xfe, 0x73, 0xc8, 0x3e, 0x6a, 0x02,
+ 0xb9, 0x48, 0x01, 0xd6, 0x50, 0x00, 0x3e, 0x9a,
+ 0xb0, 0x1d, 0x3e, 0x74, 0xf6, 0x3f, 0xa7, 0xd5,
+ 0xd3, 0xf7, 0x10, 0x2b, 0xf9, 0xd1, 0x9c, 0xa0,
+ 0x5c, 0x07, 0x4f, 0x82, 0xc0, 0xee, 0x06, 0xe1,
+ 0x74, 0x3c, 0x9c, 0x20, 0x0c, 0x07, 0xbb, 0x96,
+ 0x50, 0xff, 0x68, 0x24, 0x69, 0xde, 0xb0, 0x0b,
+ 0xa5, 0x04, 0x02, 0x8d, 0x9a, 0x0c, 0xa4, 0x41,
+ 0x27, 0x80, 0x32, 0xf5, 0xa8, 0x24, 0x1c, 0xf2,
+ 0x23, 0xa5, 0xc0, 0x4c, 0x5d, 0xbb, 0x01, 0x16,
+ 0xdb, 0xe1, 0x01, 0x5f, 0xe6, 0x43, 0x1e, 0xa5,
+ 0xc6, 0x5b, 0x6d, 0xc2, 0x05, 0x7e, 0x40, 0x41,
+ 0x55, 0x25, 0x1b, 0x7e, 0xb9, 0x00, 0xc3, 0x11,
+ 0xe0, 0x10, 0x46, 0xb8, 0x2e, 0x79, 0xe4, 0x21,
+ 0x95, 0xaa, 0x0e, 0xdd, 0x5c, 0x52, 0xb3, 0xd2,
+ 0xe4, 0x26, 0x51, 0x76, 0x10, 0x57, 0xfc, 0x96,
+ 0x41, 0xfc, 0x42, 0x85, 0x41, 0x44, 0x4d, 0x10,
+ 0x08, 0x03, 0x46, 0x7c, 0x00, 0xc9, 0xfb, 0x71,
+ 0x9d, 0x45, 0x90, 0xcd, 0x1f, 0xeb, 0x31, 0x4f,
+ 0xee, 0x0c, 0x41, 0xfd, 0x81, 0x05, 0x6f, 0x4c,
+ 0xc4, 0x1b, 0x8f, 0x59, 0x05, 0x46, 0x06, 0x5b,
+ 0xc8, 0x65, 0x37, 0xc1, 0x34, 0xec, 0xdb, 0xea,
+ 0x11, 0xdd, 0x99, 0xd6, 0xe7, 0x93, 0x42, 0x39,
+ 0xc7, 0x5d, 0x0d, 0x1f, 0x7b, 0x0b, 0x9e, 0x55,
+ 0xcc, 0x65, 0x26, 0xc1, 0x10, 0x4e, 0xe0, 0x8d,
+ 0x1f, 0x62, 0x28, 0x54, 0xfd, 0x08, 0xd1, 0xf5,
+ 0x33, 0x3d, 0xd6, 0xea, 0x8e, 0x74, 0x90, 0x03,
+ 0x2d, 0x2d, 0x02, 0x5b, 0x05, 0xf0, 0x34, 0x7f,
+ 0x1c, 0xce, 0x9e, 0x9d, 0x3b, 0x47, 0xc5, 0x8c,
+ 0x5b, 0x5c, 0xd2, 0x05, 0x67, 0x30, 0xcd, 0x1e,
+ 0xfd, 0xf9, 0xf7, 0xf0, 0x9a, 0xcf, 0x36, 0x04,
+ 0x10, 0x64, 0xc4, 0x25, 0xbc, 0xbf, 0x79, 0x4f,
+ 0xa5, 0x8a, 0x65, 0xa7, 0x91, 0x96, 0xfd, 0x95,
+ 0x6e, 0x73, 0x23, 0x09, 0x6d, 0x52, 0x8a, 0xd1,
+ 0xf2, 0x03, 0x1d, 0xf4, 0x6c, 0xa5, 0x1f, 0xb2,
+ 0xf9, 0x07, 0xc5, 0xd8, 0xc7, 0xb7, 0x60, 0x05,
+ 0x7e, 0xca, 0x2c, 0xb7, 0x70, 0xfb, 0x25, 0xdc,
+ 0x14, 0xa0, 0x4c, 0x20, 0x95, 0x08, 0xc4, 0xf2,
+ 0x91, 0x36, 0xed, 0x80, 0x53, 0xbb, 0x6c, 0x94,
+ 0xee, 0x92, 0x05, 0x72, 0x49, 0x3a, 0xfe, 0x60,
+ 0x22, 0xec, 0x49, 0x8b, 0x60, 0x7a, 0x16, 0x58,
+ 0x06, 0x01, 0xa7, 0x4d, 0x23, 0x30, 0xc4, 0x08,
+ 0x16, 0xee, 0x46, 0x23, 0xa1, 0x01, 0x1e, 0x06,
+ 0x40, 0x50, 0x82, 0xb0, 0x18, 0xc8, 0x32, 0x02,
+ 0x0b, 0x2c, 0x0d, 0x02, 0x51, 0xa4, 0x00, 0x30,
+ 0xeb, 0xa4, 0x05, 0xb2, 0x12, 0x1b, 0x77, 0xfd,
+ 0x84, 0xeb, 0xd9, 0x10, 0x36, 0xf6, 0x50, 0x0e,
+ 0xb7, 0x96, 0x01, 0x04, 0x7e, 0xca, 0xcb, 0x02,
+ 0x21, 0x99, 0x88, 0x0b, 0x91, 0xed, 0x03, 0x91,
+ 0x9c, 0xeb, 0xab, 0xd0, 0x37, 0x1d, 0x08, 0x77,
+ 0x64, 0x19, 0x87, 0xfb, 0x82, 0xcd, 0x07, 0x30,
+ 0xba, 0x10, 0x7f, 0xd2, 0x54, 0x2b, 0x5b, 0x81,
+ 0x98, 0xd3, 0x14, 0xc0, 0x32, 0x42, 0x94, 0x2b,
+ 0x90, 0x1a, 0x03, 0x9d, 0xbc, 0x86, 0x83, 0xfe,
+ 0x47, 0x14, 0x46, 0x40, 0x6e, 0x5a, 0x62, 0x01,
+ 0x6f, 0xe9, 0x0a, 0x53, 0xfb, 0x91, 0x3a, 0xc9,
+ 0x80, 0x0e, 0x96, 0x7b, 0x0a, 0x0f, 0xda, 0xc8,
+ 0x14, 0x5b, 0xcf, 0xa0, 0x1d, 0x4d, 0x96, 0x6a,
+ 0x03, 0x1e, 0x8e, 0x42, 0x5b, 0xff, 0xb1, 0x3a,
+ 0x70, 0xf8, 0x25, 0xbf, 0xdb, 0x31, 0x07, 0xf9,
+ 0x10, 0xe5, 0x00, 0xc0, 0x3a, 0x9c, 0xad, 0xb2,
+ 0x07, 0x9f, 0xf1, 0x05, 0xa6, 0xda, 0x40, 0x65,
+ 0x82, 0x08, 0x1c, 0xa2, 0x48, 0x07, 0x2b, 0x35,
+ 0x81, 0xa6, 0x04, 0x20, 0x72, 0xa0, 0x80, 0x08,
+ 0x3e, 0xc2, 0x26, 0x13, 0x3c, 0x14, 0x80, 0xbb,
+ 0xfb, 0x24, 0x10, 0x40, 0xa8, 0x49, 0x90, 0x13,
+ 0x0a, 0x61, 0xa4, 0xc5, 0xfd, 0xd0, 0x39, 0x5d,
+ 0x20, 0x4d, 0xdf, 0x01, 0x71, 0x6f, 0x29, 0x02,
+ 0xdb, 0xef, 0xe2, 0x14, 0xfc, 0xd4, 0x6c, 0x3f,
+ 0x09, 0xfb, 0x37, 0xc2, 0x46, 0x63, 0xf0, 0x9c,
+ 0xad, 0xd6, 0xa4, 0x49, 0x9f, 0x87, 0x42, 0x0d,
+ 0x66, 0xc0, 0xd7, 0x80, 0x30, 0x37, 0x40, 0x78,
+ 0x06, 0x63, 0x21, 0x71, 0x92, 0x0d, 0xa1, 0x47,
+ 0xf3, 0x53, 0x1b, 0x3e, 0x7a, 0x87, 0x5f, 0x72,
+ 0xb1, 0xb7, 0xdc, 0xff, 0x61, 0xf7, 0x3f, 0xd7,
+ 0x3d, 0xcf, 0x54, 0x6b, 0xce, 0x05, 0x33, 0xdc,
+ 0xe7, 0x68, 0xef, 0xca, 0x1c, 0xce, 0xa6, 0x38,
+ 0x04, 0x81, 0xcf, 0xbf, 0x22, 0x31, 0xef, 0xcf,
+ 0xdd, 0x3b, 0xf2, 0x73, 0x0f, 0x78, 0x79, 0x1b,
+ 0xf2, 0x08, 0x22, 0xf7, 0x8f, 0xdc, 0xbd, 0xe3,
+ 0xf6, 0xce, 0xec, 0x7d, 0xc3, 0xbb, 0x1f, 0x6c,
+ 0xee, 0xc2, 0x51, 0x0c, 0xb4, 0x8e, 0x03, 0x39,
+ 0x0a, 0x7a, 0xa0, 0x61, 0x35, 0xc0, 0x28, 0x25,
+ 0xb6, 0x4a, 0x22, 0xe7, 0x3e, 0xfe, 0xd3, 0xf0,
+ 0x2f, 0xb2, 0x77, 0xc8, 0x88, 0x9f, 0xa1, 0x39,
+ 0x17, 0x7d, 0x3e, 0xe5, 0xdf, 0x4f, 0xb6, 0x73,
+ 0x6f, 0xee, 0x15, 0xc0, 0x03, 0xb1, 0xbc, 0xd3,
+ 0x65, 0x50, 0x37, 0xf3, 0x7b, 0xe4, 0x04, 0xfb,
+ 0x68, 0x81, 0xc2, 0xd9, 0xc0, 0x44, 0xf8, 0x00,
+ 0x94, 0xe6, 0x56, 0x42, 0x88, 0x06, 0x11, 0xd7,
+ 0x58, 0xe5, 0x20, 0xdf, 0x9f, 0xd0, 0xb9, 0xd5,
+ 0xf6, 0xce, 0x75, 0x15, 0x3e, 0xcc, 0x80, 0x70,
+ 0xb3, 0x08, 0x11, 0x3d, 0x26, 0x25, 0x3d, 0xe6,
+ 0x10, 0x8b, 0x9c, 0x9f, 0x72, 0xe7, 0x27, 0xdb,
+ 0x37, 0x97, 0xf7, 0x0a, 0x58, 0x01, 0xd8, 0xde,
+ 0x69, 0xaa, 0x28, 0x1b, 0xf7, 0x9d, 0xf2, 0x0d,
+ 0x66, 0x05, 0x52, 0x43, 0xc0, 0x6b, 0xd8, 0x40,
+ 0xc8, 0x3b, 0xe8, 0x37, 0x49, 0x07, 0x81, 0xaf,
+ 0x5d, 0x22, 0x30, 0xd7, 0x4f, 0xdd, 0x39, 0xe1,
+ 0xf6, 0x5d, 0xf0, 0x19, 0x1e, 0x02, 0xe0, 0x54,
+ 0x8d, 0xb8, 0x1a, 0xf5, 0x42, 0x32, 0x2d, 0xf0,
+ 0x7d, 0xcb, 0x7c, 0x1f, 0x6c, 0xd6, 0x3f, 0xdc,
+ 0x35, 0x8f, 0xf6, 0xcd, 0x63, 0x9d, 0x4e, 0x1d,
+ 0x00, 0x75, 0x84, 0x58, 0x1c, 0xb6, 0x9e, 0x42,
+ 0x2d, 0x5d, 0x2d, 0x8e, 0x30, 0x06, 0x75, 0x83,
+ 0x50, 0x1c, 0xb6, 0x5c, 0x40, 0xa8, 0x0c, 0x01,
+ 0x37, 0x34, 0x01, 0x61, 0x81, 0x28, 0x10, 0x8d,
+ 0xe7, 0x88, 0x11, 0x85, 0x9b, 0x4e, 0xa2, 0x20,
+ 0x84, 0xb0, 0x1d, 0x22, 0x7a, 0x02, 0xda, 0xb9,
+ 0x11, 0xa4, 0xe9, 0x13, 0x20, 0x16, 0xd4, 0xb8,
+ 0x0c, 0x57, 0x27, 0x03, 0xcd, 0x48, 0x88, 0xc5,
+ 0x71, 0xd0, 0x3c, 0xe6, 0x04, 0x4e, 0xf0, 0x58,
+ 0x01, 0x04, 0x0e, 0x42, 0xc5, 0x44, 0xc0, 0x3a,
+ 0x68, 0x48, 0x25, 0x20, 0xa1, 0xb6, 0x61, 0x7e,
+ 0xe9, 0xa9, 0x84, 0x99, 0x08, 0x07, 0x19, 0xfb,
+ 0x63, 0x1e, 0x5d, 0xaa, 0xa7, 0x01, 0x80, 0x26,
+ 0xe3, 0xf8, 0x2c, 0x30, 0xd6, 0x02, 0x11, 0xbc,
+ 0xf1, 0xa7, 0x00, 0xba, 0xc4, 0x04, 0x0e, 0x5a,
+ 0x72, 0xfb, 0xae, 0x9c, 0xbe, 0xcd, 0x95, 0x9f,
+ 0xb3, 0xe5, 0x67, 0xe4, 0x10, 0x72, 0x01, 0x81,
+ 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01,
+ 0x84, 0x75, 0x80, 0xc7, 0x02, 0x23, 0x26, 0x90,
+ 0xb0, 0x08, 0x04, 0xb8, 0xe2, 0x81, 0xe0, 0x60,
+ 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01, 0x86, 0x64,
+ 0x00, 0xc7, 0x00, 0x83, 0x26, 0x90, 0xaf, 0xd4,
+ 0x04, 0xb2, 0x19, 0x04, 0x9c, 0x43, 0x22, 0x93,
+ 0x23, 0x4a, 0x07, 0x81, 0x80, 0xc0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x18, 0x79, 0x03, 0x1d, 0xee,
+ 0x02, 0xe8, 0x61, 0x80, 0x70, 0x53, 0x48, 0x45,
+ 0xf2, 0x09, 0x0a, 0xf8, 0x80, 0x54, 0x29, 0x11,
+ 0x4a, 0x85, 0x22, 0xc9, 0x24, 0x8e, 0x4e, 0xbd,
+ 0xc8, 0x11, 0x62, 0xfa, 0x07, 0x81, 0x80, 0xc0,
+ 0x60, 0x30, 0x18, 0x0c, 0x06, 0x18, 0x25, 0x03,
+ 0x1d, 0xe4, 0x02, 0xe8, 0x61, 0x80, 0x40, 0x53,
+ 0x48, 0x45, 0xf2, 0xc9, 0x14, 0xa6, 0x4e, 0x27,
+ 0x90, 0xc8, 0x24, 0xe2, 0x19, 0x14, 0x99, 0x15,
+ 0xa0, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x60, 0x30, 0x1a, 0x54, 0xd0, 0x2d, 0xd1, 0xbc,
+ 0x03, 0x0c, 0x01, 0x42, 0x9a, 0x42, 0x2f, 0x96,
+ 0x48, 0xa5, 0x32, 0x71, 0x3e, 0x27, 0xa0, 0x78,
+ 0x18, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0, 0x60,
+ 0x35, 0xa8, 0xb8, 0x5b, 0xa3, 0x3e, 0x06, 0x18,
+ 0x0d, 0x05, 0x34, 0x84, 0x5f, 0x29, 0x11, 0x4a,
+ 0x85, 0x22, 0xc9, 0x0c, 0x82, 0x4e, 0x21, 0x91,
+ 0x49, 0x91, 0x1a, 0x03, 0xc0, 0xc0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x03, 0x18, 0x88, 0x81, 0x8e,
+ 0xe5, 0xa1, 0x74, 0x30, 0xd0, 0x1c, 0x29, 0xa4,
+ 0x22, 0xfd, 0xcc, 0x80, 0x9e, 0x4e, 0x24, 0x10,
+ 0x49, 0xc4, 0x48, 0x7d, 0x01, 0xe0, 0x60, 0x30,
+ 0x18, 0x0c, 0x06, 0x03, 0x01, 0x94, 0x3c, 0x40,
+ 0xc7, 0x70, 0xd0, 0xba, 0x18, 0x67, 0xce, 0x14,
+ 0xd2, 0x11, 0x7e, 0xe2, 0x40, 0x4f, 0x27, 0x14,
+ 0x4a, 0xa4, 0x52, 0x99, 0x50, 0x93, 0x71, 0xe0,
+ 0x05, 0x0c, 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x60,
+ 0x30, 0x18, 0x0c, 0xe1, 0x9a, 0x06, 0x3b, 0x74,
+ 0x85, 0xd0, 0xc3, 0x3c, 0x30, 0xa6, 0x90, 0x8b,
+ 0xf6, 0xee, 0x02, 0x79, 0x38, 0x8a, 0x58, 0xb7,
+ 0x48, 0x10, 0x49, 0xb6, 0xea, 0x02, 0x4d, 0xbd,
+ 0xc0, 0x14, 0x30, 0x3c, 0x0c, 0x06, 0x03, 0x01,
+ 0x80, 0xc0, 0x60, 0x34, 0x85, 0x30, 0x18, 0xed,
+ 0x84, 0x17, 0x43, 0x0c, 0xe7, 0x02, 0x9a, 0x42,
+ 0x2f, 0xdb, 0x1c, 0x09, 0xe4, 0xe2, 0x09, 0x4c,
+ 0xa8, 0x45, 0x29, 0x12, 0x4a, 0x64, 0xb8, 0x45,
+ 0x81, 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03,
+ 0x01, 0xc4, 0x20, 0x80, 0xc7, 0x69, 0xe0, 0xba,
+ 0x18, 0x66, 0xf0, 0x14, 0xd2, 0x11, 0x7c, 0xaa,
+ 0x53, 0x22, 0x94, 0xad, 0x3e, 0x04, 0xf2, 0x74,
+ 0x1a, 0xc0, 0xf0, 0x30, 0x18, 0x0c, 0x06, 0x03,
+ 0x01, 0x80, 0xc2, 0x0c, 0x40, 0x63, 0xb3, 0xf0,
+ 0x5d, 0x0c, 0x33, 0x58, 0x0a, 0x69, 0x08, 0xbe,
+ 0x44, 0x22, 0x91, 0x88, 0x45, 0x52, 0xa1, 0x52,
+ 0xd2, 0x40, 0x31, 0x82, 0x48, 0x1e, 0x06, 0x03,
+ 0x01, 0x80, 0xc0, 0x60, 0x31, 0x18, 0x41, 0x00,
+ 0x0c, 0x76, 0x5c, 0x0b, 0xa1, 0x86, 0x66, 0xc1,
+ 0x4d, 0x21, 0x17, 0xc8, 0x84, 0x52, 0x31, 0x08,
+ 0xaa, 0x54, 0x2a, 0x59, 0xc0, 0x06, 0x50, 0x27,
+ 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0c, 0x06,
+ 0x43, 0x08, 0x0f, 0x01, 0x8e, 0xc7, 0x41, 0x74,
+ 0x30, 0xcc, 0x50, 0x29, 0xa4, 0x22, 0xf9, 0x10,
+ 0x8a, 0x46, 0x21, 0x15, 0x4a, 0x85, 0x4b, 0x27,
+ 0x00, 0xce, 0x00, 0xa0, 0x78, 0x18, 0x0c, 0x06,
+ 0x03, 0x01, 0x80, 0xcc, 0x61, 0x01, 0x30, 0x31,
+ 0xd8, 0x60, 0x2e, 0x86, 0x19, 0x79, 0x05, 0x34,
+ 0x84, 0x5f, 0x22, 0x11, 0x48, 0xc4, 0x22, 0xa9,
+ 0x50, 0xa9, 0x62, 0xc0, 0x1a, 0x5a, 0x98, 0x0f,
+ 0x03, 0x01, 0x80, 0xc0, 0x60, 0x30, 0x18, 0x0c,
+ 0x2d, 0x3a, 0x06, 0x3a, 0xfb, 0x05, 0xd0, 0xc3,
+ 0x2d, 0x00, 0xa6, 0x90, 0x8b, 0xe4, 0x12, 0x85,
+ 0x7f, 0x40, 0x9a, 0x4f, 0x22, 0x10, 0x49, 0x96,
+ 0x85, 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0c,
+ 0x46, 0x03, 0x0b, 0x3e, 0x01, 0x8e, 0xba, 0xa1,
+ 0x74, 0x30, 0xca, 0xbc, 0x29, 0xa4, 0x22, 0xf9,
+ 0x4c, 0xb2, 0x53, 0x2a, 0x11, 0x49, 0xa4, 0xd2,
+ 0x79, 0x10, 0x82, 0x4c, 0xb3, 0x10, 0x1e, 0x06,
+ 0x03, 0x01, 0x80, 0xc0, 0x64, 0x30, 0x18, 0x59,
+ 0x64, 0x0c, 0x75, 0xb2, 0x0b, 0xa1, 0x86, 0x51,
+ 0x81, 0x4d, 0x21, 0x17, 0xca, 0x84, 0x12, 0x99,
+ 0x2c, 0x9a, 0x4f, 0x22, 0x10, 0x49, 0x96, 0x41,
+ 0x03, 0xc0, 0xc0, 0x60, 0x30, 0x18, 0x0d, 0x06,
+ 0x03, 0x0b, 0x1c, 0x01, 0x8e, 0xb2, 0x21, 0x74,
+ 0x30, 0xc9, 0xac, 0x29, 0xa4, 0x22, 0xf9, 0x20,
+ 0x8a, 0x4c, 0x28, 0x58, 0x94, 0x0f, 0x03, 0x01,
+ 0x80, 0xc0, 0x60, 0x38, 0x18, 0x0c, 0x2c, 0x38,
+ 0x06, 0x3a, 0xba, 0x85, 0xd0, 0xc3, 0x24, 0xf0,
+ 0xa6, 0x90, 0x8b, 0xe4, 0xe2, 0x7d, 0x60, 0x00,
+ 0x86, 0x55, 0x29, 0xd8, 0x18, 0x0f, 0x03, 0x01,
+ 0x80, 0xc0, 0x62, 0x30, 0x18, 0x0c, 0x2b, 0xfa,
+ 0x06, 0x3a, 0xab, 0x05, 0xd0, 0xc3, 0x23, 0x00,
+ 0xa6, 0x90, 0x8b, 0xe5, 0x32, 0x2d, 0x58, 0x04,
+ 0x8a, 0x47, 0xab, 0x40, 0x15, 0x49, 0xc4, 0x4a,
+ 0xf0, 0x81, 0xe0, 0x60, 0x30, 0x18, 0x0c, 0x86,
+ 0x03, 0x01, 0x85, 0x76, 0x00, 0xc7, 0x53, 0x10,
+ 0xba, 0x18, 0x64, 0x16, 0x14, 0xd2, 0x11, 0x7c,
+ 0x88, 0x45, 0x23, 0x10, 0x4a, 0xa4, 0xc2, 0xa1,
+ 0x7c, 0x88, 0x45, 0x29, 0x92, 0xca, 0x84, 0xf2,
+ 0x85, 0x4c, 0xc0, 0x9c, 0x4c, 0x2c, 0xd6, 0xd4,
+ 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x68, 0x30, 0x18,
+ 0x0c, 0x2b, 0x58, 0x06, 0x3a, 0x82, 0x85, 0xd0,
+ 0xc3, 0x1d, 0xf0, 0xa6, 0x90, 0x8b, 0xe5, 0x42,
+ 0x79, 0x40, 0x9b, 0x51, 0x30, 0x2a, 0x56, 0x58,
+ 0x0f, 0x03, 0x01, 0x80, 0xc0, 0x70, 0x30, 0x18,
+ 0x0c, 0x2b, 0x1a, 0x06, 0x3a, 0x73, 0x05, 0xd0,
+ 0xc3, 0x1c, 0x00, 0xa6, 0x90, 0x8b, 0xe5, 0x22,
+ 0x49, 0x1c, 0x90, 0x54, 0xab, 0xc8, 0x1e, 0x06,
+ 0x03, 0x01, 0x88, 0xc0, 0x60, 0x30, 0x18, 0x55,
+ 0xc0, 0x0c, 0x74, 0xc9, 0x0b, 0xa1, 0x86, 0x34,
+ 0x61, 0x4d, 0x21, 0x17, 0xca, 0x45, 0x42, 0x61,
+ 0x48, 0x8a, 0x41, 0x22, 0x53, 0xb8, 0x08, 0xe0,
+ 0xa2, 0x69, 0x08, 0xbf, 0x4c, 0x00, 0x27, 0x93,
+ 0x88, 0xa5, 0x8a, 0x5d, 0x81, 0x04, 0x9b, 0x4b,
+ 0xc0, 0x24, 0xd3, 0x24, 0x04, 0x10, 0xe8, 0x03,
+ 0x74, 0x9b, 0x80, 0xc3, 0x17, 0x90, 0xa6, 0x90,
+ 0x8b, 0xf4, 0xa4, 0x02, 0x79, 0x38, 0xae, 0x41,
+ 0x29, 0x13, 0xa9, 0x86, 0x04, 0x70, 0x51, 0x34,
+ 0x84, 0x5f, 0xa4, 0xa8, 0x13, 0xc9, 0xc4, 0x82,
+ 0x09, 0x38, 0x89, 0x24, 0x20, 0xb7, 0x49, 0x28,
+ 0x0c, 0x31, 0x55, 0x0a, 0x69, 0x08, 0xbf, 0x48,
+ 0x00, 0x27, 0x93, 0x88, 0xa5, 0x2a, 0x47, 0x81,
+ 0x48, 0x14, 0x4d, 0x21, 0x17, 0xe8, 0xe6, 0x04,
+ 0xf2, 0x71, 0x04, 0xa6, 0x54, 0x22, 0x94, 0x89,
+ 0x25, 0x32, 0x5c, 0x87, 0x02, 0xdd, 0x22, 0x40,
+ 0x30, 0xc4, 0xbc, 0x29, 0xa4, 0x22, 0xfd, 0x16,
+ 0x80, 0x9e, 0x4e, 0xa3, 0xe8, 0x11, 0xa8, 0xb8,
+ 0x14, 0x12, 0xa1, 0x26, 0x8c, 0x60, 0x0a, 0x26,
+ 0x90, 0x8b, 0xf4, 0x47, 0x02, 0x79, 0x38, 0x90,
+ 0x41, 0x27, 0x11, 0x23, 0xe8, 0x16, 0xe8, 0xfe,
+ 0x01, 0x86, 0x20, 0xe1, 0x4d, 0x21, 0x17, 0xe8,
+ 0x64, 0x04, 0xf2, 0x71, 0x4c, 0xa8, 0x4f, 0x28,
+ 0x52, 0xf4, 0x0f, 0x03, 0x01, 0x80, 0xc8, 0x60,
+ 0x30, 0x18, 0x0c, 0x29, 0x68, 0x06, 0x3a, 0x06,
+ 0x85, 0xd0, 0xc3, 0x0e, 0x70, 0xa6, 0x90, 0x8b,
+ 0xe5, 0x32, 0x29, 0x4a, 0x84, 0x40, 0x43, 0x22,
+ 0x97, 0xc9, 0xc4, 0xf2, 0xa1, 0x26, 0x80, 0xa1,
+ 0x41, 0x2a, 0x12, 0x68, 0x2c, 0x00, 0xa1, 0x81,
+ 0xe0, 0x60, 0x30, 0x18, 0x0d, 0x06, 0x03, 0x01,
+ 0x85, 0x22, 0x00, 0xc7, 0x3e, 0x10, 0xba, 0x18,
+ 0x61, 0x76, 0x14, 0xd2, 0x11, 0x7c, 0xa6, 0x45,
+ 0x29, 0x4f, 0xd8, 0x08, 0x64, 0x52, 0xf9, 0x38,
+ 0x9e, 0x54, 0x24, 0xcf, 0x64, 0x28, 0x25, 0x42,
+ 0x4c, 0xfa, 0x80, 0x14, 0x30, 0x3c, 0x0c, 0x06,
+ 0x03, 0x01, 0xa0, 0xc0, 0x60, 0x30, 0xa2, 0xe0,
+ 0x18, 0xe7, 0x6a, 0x17, 0x43, 0x0c, 0x23, 0xc2,
+ 0x9a, 0x42, 0x2f, 0x94, 0xc8, 0xa5, 0x29, 0xe5,
+ 0x01, 0x0c, 0x8a, 0x5f, 0x27, 0x13, 0xca, 0x84,
+ 0x99, 0xd6, 0x85, 0x04, 0xa8, 0x49, 0x9d, 0xf0,
+ 0x17, 0xe7, 0x7e, 0x03, 0x32, 0xc5, 0x0d, 0x00,
+ 0xf0, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x01, 0x80,
+ 0xc0, 0x8d, 0x14, 0xb0, 0xb7, 0x45, 0x4c, 0x0c,
+ 0x30, 0x5e, 0x0a, 0x69, 0x08, 0xbe, 0x54, 0x2c,
+ 0x94, 0x08, 0xa4, 0xd2, 0x09, 0x4c, 0x97, 0x41,
+ 0x40, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x60, 0x46, 0xa0, 0x58, 0x18, 0xe6, 0xc8, 0x17,
+ 0x43, 0x0c, 0x0f, 0x82, 0x9a, 0x42, 0x2f, 0xcd,
+ 0xa4, 0x09, 0xf3, 0x7d, 0x02, 0x09, 0x4c, 0x97,
+ 0x3f, 0x40, 0x3c, 0x0c, 0x06, 0x03, 0x01, 0x80,
+ 0xc0, 0x8c, 0x30, 0x9f, 0x58, 0x18, 0xe6, 0x88,
+ 0x17, 0x43, 0x0c, 0x07, 0x82, 0x9a, 0x42, 0x2f,
+ 0x91, 0x08, 0xa4, 0x62, 0x69, 0x04, 0xa6, 0x4b,
+ 0x9e, 0xa8, 0x1e, 0x06, 0x03, 0x01, 0x80, 0xc0,
+ 0x66, 0x30, 0x18, 0x4f, 0x30, 0x0c, 0x73, 0x25,
+ 0x0b, 0xa1, 0x86, 0x08, 0xe1, 0x4d, 0x21, 0x17,
+ 0xc9, 0xa4, 0xf2, 0x21, 0x14, 0x9a, 0x41, 0x29,
+ 0x92, 0xe7, 0x6a, 0x07, 0x81, 0x80, 0xc0, 0x60,
+ 0x30, 0x21, 0x8c, 0x06, 0x13, 0xac, 0x03, 0x1c,
+ 0xc1, 0x42, 0xe8, 0x61, 0x81, 0x38, 0x53, 0x48,
+ 0x45, 0xf2, 0x69, 0x24, 0xa6, 0x43, 0x26, 0x90,
+ 0x4a, 0x64, 0xba, 0x53, 0x05, 0x8e, 0x5d, 0xc1,
+ 0x74, 0x30, 0xc0, 0x40, 0x29, 0x24, 0x42, 0x79,
+ 0x2e, 0x73, 0xe1, 0x63, 0x96, 0xf0, 0x5d, 0x0c,
+ 0x30, 0x00, 0x0a, 0x49, 0x10, 0x86, 0x41, 0x27,
+ 0x10, 0xc8, 0xa4, 0xc9, 0xaf, 0x85, 0x8e, 0x59,
+ 0x41, 0x74, 0x30, 0xc1, 0xdc, 0x29, 0x24, 0x42,
+ 0x09, 0x0a, 0x5a, 0xe0, 0x54, 0x05, 0x0d, 0x20,
+ 0xfc, 0x16, 0xe8, 0x43, 0x01, 0x86, 0x0c, 0x81,
+ 0x49, 0x22, 0x14, 0x88, 0xa5, 0x42, 0x91, 0x64,
+ 0x14, 0x35, 0x83, 0x58, 0x5b, 0xa0, 0xe6, 0x06,
+ 0x18, 0x28, 0x85, 0x24, 0x88, 0x49, 0x23, 0x93,
+ 0xa5, 0x60, 0x04, 0x50, 0x50, 0xda, 0x0a, 0xe1,
+ 0x6e, 0x82, 0xf8, 0x18, 0x60, 0x7a, 0x14, 0x92,
+ 0x21, 0x64, 0x8a, 0x53, 0x05, 0x0d, 0xe0, 0x8c,
+ 0x16, 0xe8, 0x27, 0x01, 0x86, 0x05, 0x81, 0x49,
+ 0x22, 0x13, 0x89, 0xe0, 0xa1, 0xc4, 0x0d, 0x82,
+ 0xdd, 0x03, 0xe0, 0x30, 0xc0, 0x70, 0x29, 0x24,
+ 0x49, 0x3b, 0x01, 0x3c, 0xa6, 0x45, 0x05, 0x0e,
+ 0x60, 0x46, 0x16, 0xe8, 0x15, 0x81, 0x86, 0x01,
+ 0x21, 0x49, 0x22, 0x12, 0x08, 0xa4, 0xc2, 0x84,
+ 0x04, 0x42, 0xde, 0x75, 0x3a, 0x1c, 0x0e, 0xb0,
+ 0xff, 0x03, 0x25, 0x72, 0x44, 0x5b, 0x00, 0xf2,
+ 0xa7, 0x9d, 0x4e, 0x87, 0x03, 0xa9, 0xd2, 0xb6,
+ 0xc3, 0x53, 0x85, 0x69, 0x0e, 0xe0, 0x5e, 0x16,
+ 0x4a, 0xd3, 0x08, 0xb6, 0x6f, 0xc0, 0x65, 0xad,
+ 0x28, 0x51, 0x2b, 0x34, 0x83, 0xb8, 0x0a, 0x05,
+ 0xd6, 0x2b, 0x02, 0x2d, 0x1f, 0x4b, 0x04, 0xa4,
+ 0x10, 0xbb, 0x03, 0x0c, 0x52, 0x08, 0xf9, 0x2a,
+ 0xe3, 0x10, 0x40, 0x10, 0x2c, 0x70, 0x61, 0x2b,
+ 0xe8, 0x2a, 0x25, 0xe0, 0x31, 0x15, 0xc9, 0x68,
+ 0x0d, 0x92, 0x79, 0x03, 0x1c, 0x59, 0xc0, 0xcb,
+ 0x26, 0xd0, 0x1e, 0x88, 0x23, 0x9c, 0x00, 0xa3,
+ 0xa1, 0xbe, 0x50, 0x46, 0x0a, 0x88, 0x58, 0xd8,
+ 0xe0, 0x66, 0x57, 0x59, 0x63, 0x01, 0xbe, 0x22,
+ 0xa0, 0x0a, 0x92, 0x40, 0x18, 0xe0, 0x44, 0x57,
+ 0x51, 0x00, 0xae, 0x04, 0xe0, 0x21, 0x80, 0x90,
+ 0x1c, 0xe0, 0x52, 0x46, 0x53, 0x64, 0x10, 0x00,
+ 0x14, 0x30, 0x8b, 0x48, 0x9a, 0x4c, 0xd1, 0x13,
+ 0x2b, 0x61, 0xb2, 0x3c, 0x40, 0x74, 0x8e, 0x00,
+ 0x51, 0xa5, 0x08, 0x67, 0xb9, 0x2a, 0x38, 0x80,
+ 0xe1, 0x18, 0x40, 0x29, 0x9d, 0x0c, 0x26, 0x3a,
+ 0x6e, 0x00, 0xb6, 0x03, 0x22, 0x30, 0x9f, 0x97,
+ 0xda, 0x63, 0xd7, 0x16, 0x69, 0x00, 0x30, 0x82,
+ 0x3d, 0xdf, 0x6c, 0x8f, 0x72, 0xc2, 0xa3, 0xdd,
+ 0xd0, 0xa8, 0xe7, 0x29, 0xda, 0x02, 0x60, 0x73,
+ 0x88, 0x80, 0x5c, 0xa2, 0x6a, 0x47, 0x38, 0xe7,
+ 0x84, 0x2a, 0x39, 0xe5, 0x0a, 0x8e, 0xba, 0x42,
+ 0xa0, 0x26, 0x46, 0xc3, 0x61, 0x8e, 0x31, 0x27,
+ 0x31, 0x80, 0x18, 0x5b, 0x0d, 0x90, 0xd2, 0x03,
+ 0xa4, 0x2c, 0x02, 0x8d, 0x17, 0x43, 0x1d, 0xc2,
+ 0xb8, 0x2c, 0x71, 0x59, 0x0b, 0x84, 0x0a, 0x40,
+ 0xc7, 0x15, 0x20, 0x33, 0x45, 0x74, 0xc6, 0x10,
+ 0x0c, 0x0b, 0x61, 0xb2, 0x14, 0xc0, 0x74, 0x84,
+ 0x20, 0x51, 0xa2, 0x90, 0x63, 0xb8, 0x41, 0x05,
+ 0xda, 0x2f, 0x43, 0x7b, 0x85, 0xab, 0x08, 0x20,
+ 0x18, 0x06, 0x43, 0x29, 0xe2, 0x12, 0x02, 0x7d,
+ 0x05, 0x42, 0x71, 0x64, 0x03, 0x03, 0xc0, 0xe0,
+ 0x60, 0x30, 0x18, 0x0c, 0x06, 0x03, 0x08, 0x49,
+ 0x81, 0xa4, 0xdd, 0x03, 0x90, 0x39, 0x1d, 0x22,
+ 0x40, 0x25, 0xc8, 0x0f, 0x01, 0xb2, 0x6d, 0x60,
+ 0x6e, 0x32, 0x99, 0x20, 0xa8, 0x07, 0x08, 0x36,
+ 0x45, 0x8e, 0x10, 0xd5, 0x30, 0x83, 0x52, 0x11,
+ 0xa1, 0xd0, 0x36, 0x93, 0x71, 0x90, 0xca, 0x78,
+ 0x81, 0x48, 0x5a, 0x4d, 0xc6, 0x43, 0x29, 0xe0,
+ 0x15, 0x02, 0x35, 0x90, 0x0c, 0x0f, 0x03, 0x81,
+ 0x80, 0xc0, 0x60, 0x30, 0x18, 0x0c, 0x20, 0x34,
+ 0x06, 0x13, 0x71, 0x90, 0x40, 0x69, 0x33, 0x42,
+ 0x2b, 0x8c, 0xa6, 0xc3, 0x9c, 0x34, 0x80, 0xdb,
+ 0x06, 0x89, 0x3b, 0x1b, 0xcd, 0x26, 0x41, 0x04,
+ 0x30, 0xc0, 0xc8, 0x69, 0x33, 0x40, 0xaa, 0x8e,
+ 0xc6, 0x93, 0x94, 0x0f, 0x00, 0xc3, 0x01, 0x90,
+ 0x36, 0xc0, 0xd4, 0x0d, 0x10, 0x8b, 0x00, 0x54,
+ 0x09, 0x14, 0xed, 0x03, 0x10, 0x39, 0xc1, 0x94,
+ 0x2e, 0x50, 0x82, 0x23, 0x9c, 0x09, 0x42, 0x15,
+ 0x02, 0x52, 0x85, 0x17, 0x60, 0x30, 0x10, 0xa8,
+ 0x15, 0x1c, 0x2a, 0x05, 0x40, 0x5b, 0x83, 0x00,
+ 0x19, 0x0d, 0x26, 0x68, 0x0b, 0x01, 0xa0, 0xd2,
+ 0x64, 0x32, 0xc1, 0x74, 0x2c, 0x70, 0xcf, 0x03,
+ 0x99, 0xd0, 0xc3, 0x04, 0xd0, 0x10, 0x1e, 0xa1,
+ 0x36, 0x06, 0xf8, 0x06, 0x84, 0xfe, 0x27, 0x62,
+ 0x22, 0x81, 0x28, 0x48, 0xa0, 0xbc, 0x06, 0xf3,
+ 0x69, 0xc2, 0x00, 0xc0, 0x65, 0x10, 0x0c, 0x07,
+ 0xb1, 0x0c, 0x19, 0xf9, 0xf4, 0xfb, 0x12, 0x10,
+ 0x11, 0x08, 0x0f, 0xa7, 0xd8, 0x30, 0x81, 0x8c,
+ 0xde, 0x6d, 0x38, 0x40, 0x50, 0x0c, 0xa2, 0x01,
+ 0x80, 0xf6, 0x1e, 0x41, 0x73, 0x83, 0x78, 0x0b,
+ 0x4c, 0x70, 0xbc, 0x03, 0x94, 0x02, 0x02, 0x15,
+ 0x0e, 0x60, 0x3d, 0x9e, 0xe0, 0x10, 0x16, 0x43,
+ 0xa9, 0xc2, 0x0c, 0xe0, 0x6f, 0x84, 0x20, 0x5c,
+ 0xcf, 0x82, 0x03, 0x74, 0x0d, 0x00, 0xc7, 0x05,
+ 0x90, 0xb7, 0xc0, 0x40, 0x2c, 0x30, 0x55, 0x01,
+ 0x01, 0xf0, 0x14, 0x62, 0x84, 0xd8, 0x1a, 0x4d,
+ 0xc0, 0xa3, 0x84, 0x09, 0x40, 0xe7, 0x06, 0xf0,
+ 0x3b, 0xc2, 0x50, 0x0c, 0x80, 0xa1, 0xfc, 0x30,
+ 0xc0, 0xe0, 0x20, 0x18, 0x0f, 0x61, 0xa4, 0x06,
+ 0x28, 0x43, 0x01, 0xd2, 0x00, 0x80, 0x45, 0x39,
+ 0x40, 0x84, 0x0e, 0x50, 0x9d, 0x03, 0x79, 0xd4,
+ 0xe9, 0x07, 0x60, 0x33, 0x08, 0x20, 0x44, 0x07,
+ 0x83, 0xa0, 0x80, 0xef, 0x01, 0xb0, 0x34, 0x42,
+ 0xf4, 0x0e, 0x90, 0xa2, 0x03, 0x29, 0x96, 0x1b,
+ 0xa1, 0x20, 0x3e, 0x9f, 0x44, 0x40, 0xa1, 0x94,
+ 0x23, 0x80, 0xe0, 0x20, 0x19, 0x42, 0x24, 0x0e,
+ 0x02, 0x01, 0xfc, 0x22, 0x42, 0x5b, 0x0f, 0xd0,
+ 0x3a, 0x08, 0x07, 0xe7, 0xd3, 0xec, 0x11, 0x04,
+ 0x60, 0x3d, 0x05, 0x1d, 0xcd, 0x06, 0x98, 0x38,
+ 0x80, 0x28, 0xdc, 0x4c, 0x87, 0x40, 0x1c, 0xc4,
+ 0x03, 0x11, 0x58, 0x80, 0xe8, 0x6f, 0x10, 0x1b,
+ 0x89, 0x90, 0xdc, 0x03, 0x98, 0x2a, 0x02, 0x60,
+ 0x70, 0x8a, 0xe0, 0x1d, 0x01, 0x43, 0xf8, 0x2b,
+ 0x85, 0xa4, 0xcc, 0x20, 0x82, 0xf0, 0x1d, 0x0d,
+ 0xf0, 0x16, 0x03, 0x7c, 0x21, 0xc2, 0xc3, 0x00,
+ 0x70, 0x10, 0x41, 0x64, 0x0c, 0x86, 0x93, 0x30,
+ 0x28, 0xdc, 0x4c, 0x85, 0xa0, 0x1c, 0xc4, 0x10,
+ 0x56, 0x03, 0x21, 0xbc, 0x14, 0x28, 0x82, 0xa8,
+ 0x18, 0xe0, 0x20, 0x02, 0x90, 0x54, 0x13, 0x80,
+ 0xde, 0x70, 0x05, 0x41, 0x24, 0x0c, 0x70, 0x60,
+ 0x03, 0x0c, 0x29, 0x00, 0x41, 0x02, 0x90, 0x1e,
+ 0x88, 0x0d, 0x26, 0x60, 0x51, 0x8a, 0x1c, 0xa0,
+ 0x69, 0x37, 0x02, 0x8e, 0x10, 0x00, 0x03, 0x9c,
+ 0x2e, 0x40, 0xef, 0x0d, 0xe0, 0x32, 0x02, 0x86,
+ 0x46, 0x43, 0xa9, 0xc0, 0x40, 0x3f, 0x3e, 0x9f,
+ 0x44, 0x03, 0x01, 0xe8, 0x28, 0xee, 0x68, 0x34,
+ 0x9b, 0x0c, 0xa0, 0xa3, 0x81, 0xbe, 0x05, 0xc0,
+ 0x70, 0x84, 0x00, 0x19, 0x44, 0x07, 0xa8, 0x28,
+ 0x01, 0xbe, 0x1d, 0x00, 0x6c, 0x82, 0xd8, 0x18,
+ 0x4d, 0x90, 0xe7, 0x03, 0x91, 0x96, 0x10, 0xe0,
+ 0x61, 0x87, 0x90, 0x0c, 0xa0, 0xa2, 0x06, 0xf3,
+ 0x80, 0x2a, 0x03, 0x00, 0x64, 0x34, 0x99, 0xa0,
+ 0x04, 0x13, 0x08, 0x64, 0x81, 0xb2, 0x07, 0x80,
+ 0x61, 0x36, 0x43, 0x20, 0x07, 0x62, 0x03, 0x49,
+ 0xb6, 0x00, 0x20, 0x64, 0x34, 0x98, 0x60, 0x72,
+ 0x02, 0x03, 0x19, 0xbc, 0xda, 0x70, 0x34, 0x9b,
+ 0x20, 0xb2, 0x06, 0xf3, 0x71, 0xb0, 0xf2, 0x0a,
+ 0x38, 0x40, 0x84, 0x0e, 0xd0, 0x32, 0x03, 0xac,
+ 0x0e, 0x00, 0xa6, 0x22, 0x10, 0x11, 0x89, 0x24,
+ 0x32, 0x61, 0x7c, 0xae, 0x41, 0x27, 0x15, 0x0b,
+ 0xe4, 0x62, 0x49, 0x30, 0x8a, 0x22, 0x10, 0x11,
+ 0x49, 0xc5, 0x62, 0x49, 0x48, 0x9e, 0x4e, 0x26,
+ 0x91, 0x49, 0xc5, 0x41, 0xf8, 0x82, 0x02, 0x40,
+ 0x6f, 0x38, 0x08, 0x0b, 0x66, 0x93, 0x34, 0x17,
+ 0x00, 0x74, 0x20, 0x39, 0x0b, 0xcd, 0xe2, 0x01,
+ 0x8c, 0x17, 0x86, 0xe4, 0x2f, 0x3b, 0x88, 0x06,
+ 0x70, 0x54, 0x1b, 0xb8, 0xbc, 0xde, 0x20, 0x19,
+ 0x41, 0x28, 0x6c, 0x50, 0x1e, 0x01, 0x00, 0xe2,
+ 0x04, 0x22, 0x3b, 0x81, 0xe8, 0x5a, 0x4d, 0xc6,
+ 0x33, 0x61, 0xd4, 0xc8, 0x65, 0x32, 0x02, 0x8e,
+ 0x42, 0xf3, 0x78, 0x80, 0xc5, 0x00, 0x40, 0x10,
+ 0x1b, 0xce, 0x10, 0x45, 0x01, 0x69, 0x98, 0xd2,
+ 0x6c, 0x32, 0x88, 0x06, 0x03, 0xd1, 0x01, 0xa4,
+ 0xcc, 0x0a, 0x34, 0x9b, 0x8c, 0x66, 0xc3, 0xa9,
+ 0x90, 0xca, 0x2d, 0x33, 0x1a, 0x4d, 0x86, 0x50,
+ 0x51, 0x94, 0xd8, 0x73, 0x32, 0x82, 0x8c, 0x87,
+ 0x23, 0x79, 0xc0, 0x15, 0x02, 0x00, 0x32, 0x1a,
+ 0x4c, 0xc0, 0xa1, 0xd8, 0x28, 0x74, 0x20, 0x34,
+ 0x9b, 0x8c, 0x66, 0xc3, 0xa9, 0x90, 0xca, 0x20,
+ 0x38, 0x40, 0x20, 0x0e, 0x66, 0x51, 0x69, 0xdc,
+ 0xde, 0x72, 0x32, 0x08, 0x0d, 0x26, 0xe3, 0x19,
+ 0xb0, 0xea, 0x64, 0x32, 0x99, 0x04, 0x03, 0xb0,
+ 0x51, 0x6c, 0xca, 0x6e, 0x32, 0x1a, 0x4c, 0xc5,
+ 0xd0, 0x50,
+ };
+
+#endif /* !FICL_WANT_LZ_SOFTCORE */
+
+
+void ficlSystemCompileSoftCore(ficlSystem *system)
+{+ ficlVm *vm = system->vmList;
+ int returnValue;
+ ficlCell oldSourceID = vm->sourceId;
+ ficlString s;
+#if FICL_WANT_LZ_SOFTCORE
+ char *ficlSoftcoreUncompressed = NULL;
+ size_t gotUncompressedSize = 0;
+ returnValue = ficlLzUncompress(ficlSoftcoreCompressed, (unsigned char **)&ficlSoftcoreUncompressed, &gotUncompressedSize);
+ FICL_VM_ASSERT(vm, returnValue == 0);
+ FICL_VM_ASSERT(vm, gotUncompressedSize == ficlSoftcoreUncompressedSize);
+#endif /* FICL_WANT_LZ_SOFTCORE */
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_POINTER(s, (char *)(ficlSoftcoreUncompressed));
+ FICL_STRING_SET_LENGTH(s, ficlSoftcoreUncompressedSize);
+ returnValue = ficlVmExecuteString(vm, s);
+ vm->sourceId = oldSourceID;
+#if FICL_WANT_LZ_SOFTCORE
+ free(ficlSoftcoreUncompressed);
+#endif /* FICL_WANT_LZ_SOFTCORE */
+ FICL_VM_ASSERT(vm, returnValue != FICL_VM_STATUS_ERROR_EXIT);
+ return;
+}
+
+/* end-of-file */
--- a/softwords/ficllocal.fr
+++ /dev/null
@@ -1,46 +1,0 @@
-\ ** ficl/softwords/ficllocal.fr
-\ ** stack comment style local syntax...
-\ {{ a b c -- d e }}-\ variables before the "--" are initialized in reverse order
-\ from the stack. Those after the "--" are zero initialized
-\ Uses locals...
-\ locstate: 0 = looking for -- or }}
-\ 1 = found --
-hide
-0 constant zero
-
-: ?-- s" --" compare 0= ;
-: ?}} s" }}" compare 0= ;
-
-set-current
-
-: {{- 0 dup locals| nLocs locstate |
- begin
- parse-word
- ?dup 0= abort" Error: out of text without seeing }}"
- 2dup 2dup ?-- -rot ?}} or 0=
- while
- nLocs 1+ to nLocs
- repeat
-
- ?-- if 1 to locstate endif
-
- nLocs 0 do
- (local)
- loop
-
- locstate 1 = if
- begin
- parse-word
- 2dup ?}} 0=
- while
- postpone zero (local)
- repeat
- 2drop
- endif
-
- 0 0 (local)
-; immediate compile-only
-
-previous
--- a/softwords/forml.fr
+++ /dev/null
@@ -1,72 +1,0 @@
-\ examples from FORML conference paper Nov 98
-\ sadler
-.( loading FORML examples ) cr
-object --> sub c-example
- cell: .cell0
- c-4byte obj: .nCells
- 4 c-4byte array: .quad
- c-byte obj: .length
- 79 chars: .name
-
- : init ( inst class -- )
- 2dup object => init
- s" aardvark" 2swap --> set-name
- ;
-
- : get-name ( inst class -- c-addr u )
- 2dup
- --> .name -rot ( c-addr inst class )
- --> .length --> get
- ;
-
- : set-name { c-addr u 2:this -- }- u this --> .length --> set
- c-addr this --> .name u move
- ;
-
- : ? ( inst class ) c-example => get-name type cr ;
-end-class
-
-
-: test ." this is a test" cr ;
-' test
-c-word --> ref testref
-
-\ add a method to c-word...
-c-word --> get-wid ficl-set-current
-\ list dictionary thread
-: list ( inst class )
- begin
- 2dup --> get-name type cr
- --> next over
- 0= until
- 2drop
-;
-set-current
-
-object subclass c-led
- c-byte obj: .state
-
- : on { led# 2:this -- }- this --> .state --> get
- 1 led# lshift or dup !oreg
- this --> .state --> set
- ;
-
- : off { led# 2:this -- }- this --> .state --> get
- 1 led# lshift invert and dup !oreg
- this --> .state --> set
- ;
-
-end-class
-
-
-object subclass c-switch
-
- : ?on { bit# 2:this -- flag }-
- 1 bit# lshift
- ;
-end-class
-
--- a/softwords/ifbrack.fr
+++ /dev/null
@@ -1,48 +1,0 @@
-\ ** ficl/softwords/ifbrack.fr
-\ ** ANS conditional compile directives [if] [else] [then]
-\ ** Requires ficl 2.0 or greater...
-
-hide
-
-: ?[if] ( c-addr u -- c-addr u flag )
- 2dup s" [if]" compare-insensitive 0=
-;
-
-: ?[else] ( c-addr u -- c-addr u flag )
- 2dup s" [else]" compare-insensitive 0=
-;
-
-: ?[then] ( c-addr u -- c-addr u flag )
- 2dup s" [then]" compare-insensitive 0= >r
- 2dup s" [endif]" compare-insensitive 0= r>
- or
-;
-
-set-current
-
-: [else] ( -- )
- 1 \ ( level )
- begin
- begin
- parse-word dup while \ ( level addr len )
- ?[if] if \ ( level addr len )
- 2drop 1+ \ ( level )
- else \ ( level addr len )
- ?[else] if \ ( level addr len )
- 2drop 1- dup if 1+ endif
- else
- ?[then] if 2drop 1- else 2drop endif
- endif
- endif ?dup 0= if exit endif \ level
- repeat 2drop \ level
- refill 0= until \ level
- drop
-; immediate
-
-: [if] ( flag -- )
-0= if postpone [else] then ; immediate
-
-: [then] ( -- ) ; immediate
-: [endif] ( -- ) ; immediate
-
-previous
--- a/softwords/jhlocal.fr
+++ /dev/null
@@ -1,100 +1,0 @@
-\ #if FICL_WANT_LOCALS
-\ ** ficl/softwords/jhlocal.fr
-\ ** stack comment style local syntax...
-\ { a b c | cleared -- d e }
-\ variables before the "|" are initialized in reverse order
-\ from the stack. Those after the "|" are zero initialized.
-\ Anything between "--" and "}" is treated as comment
-\ Uses locals...
-\ locstate: 0 = looking for | or -- or }}
-\ 1 = found |
-\ 2 = found --
-\ 3 = found }
-\ 4 = end of line
-\
-\ revised 2 June 2000 - { | a -- } now works correctly
-.( loading Johns-Hopkins locals ) cr
-hide
-0 constant zero
-
-: ?-- ( c-addr u -- c-addr u flag )
- 2dup s" --" compare 0= ;
-: ?} ( c-addr u -- c-addr u flag )
- 2dup s" }" compare 0= ;
-: ?| ( c-addr u -- c-addr u flag )
- 2dup s" |" compare 0= ;
-
-\ examine name - if it's a 2local (starts with "2:"),
-\ nibble the prefix (the "2:") off the name and push true.
-\ Otherwise push false
-\ Problem if the local is named "2:" - we fall off the end...
-: ?2loc ( c-addr u -- c-addr u flag )
- over dup c@ [char] 2 =
- swap 1+ c@ [char] : = and
- if
- 2 - swap char+ char+ swap \ dcs/jws: nibble the '2:'
- true
- else
- false
- endif
-;
-
-: ?delim ( c-addr u -- state | c-addr u 0 )
- ?| if 2drop 1 exit endif
- ?-- if 2drop 2 exit endif
- ?} if 2drop 3 exit endif
- dup 0=
- if 2drop 4 exit endif
- 0
-;
-
-set-current
-
-: {
- 0 dup locals| locstate |
-
- \ stack locals until we hit a delimiter
- begin
- parse-word \ ( nLocals c-addr u )
- ?delim dup to locstate
- 0= while
- rot 1+ \ ( c-addr u ... c-addr u nLocals )
- repeat
-
- \ now unstack the locals
- 0 ?do
- ?2loc if (2local) else (local) endif
- loop \ ( )
-
- \ zero locals until -- or }
- locstate 1 = if
- begin
- parse-word
- ?delim dup to locstate
- 0= while
- ?2loc if
- postpone zero postpone zero (2local)
- else
- postpone zero (local)
- endif
- repeat
- endif
-
- 0 0 (local)
-
- \ toss words until }
- locstate 2 = if
- begin
- parse-word
- ?delim dup to locstate
- 0= while
- 2drop
- repeat
- endif
-
- locstate 3 <> abort" syntax error in { } local line"
-; immediate compile-only
-
-previous
-\ #endif
-
--- a/softwords/makefile
+++ /dev/null
@@ -1,9 +1,0 @@
-SOURCES = softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr
-
-softcore.c: softcore.pl $(SOURCES)
- ./softcore.pl $(SOURCES) >softcore.c
- cp softcore.c ..
-
-clean:
- rm *.c
-
--- a/softwords/marker.fr
+++ /dev/null
@@ -1,25 +1,0 @@
-\ ** ficl/softwords/marker.fr
-\ ** Ficl implementation of CORE EXT MARKER
-\ John Sadler, 4 Oct 98
-\ Requires ficl 2.02 FORGET-WID !!
-.( loading MARKER ) cr
-: marker ( "name" -- )
- create
- get-current ,
- get-order dup ,
- 0 ?do , loop
- does>
- 0 set-order \ clear search order
- dup body> >name drop
- here - allot \ reset HERE to my xt-addr
- dup @ ( pfa current-wid )
- dup set-current forget-wid ( pfa )
- cell+ dup @ swap ( count count-addr )
- over cells + swap ( last-wid-addr count )
- 0 ?do
- dup @ dup ( wid-addr wid wid )
- >search forget-wid ( wid-addr )
- cell-
- loop
- drop
-;
--- a/softwords/oo.fr
+++ /dev/null
@@ -1,692 +1,0 @@
-\ #if FICL_WANT_OOP
-\ ** ficl/softwords/oo.fr
-\ ** F I C L O - O E X T E N S I O N S
-\ ** john sadler aug 1998
-
-.( loading ficl O-O extensions ) cr
-17 ficl-vocabulary oop
-also oop definitions
-
-\ Design goals:
-\ 0. Traditional OOP: late binding by default for safety.
-\ Early binding if you ask for it.
-\ 1. Single inheritance
-\ 2. Object aggregation (has-a relationship)
-\ 3. Support objects in the dictionary and as proxies for
-\ existing structures (by reference):
-\ *** A ficl object can wrap a C struct ***
-\ 4. Separate name-spaces for methods - methods are
-\ only visible in the context of a class / object
-\ 5. Methods can be overridden, and subclasses can add methods.
-\ No limit on number of methods.
-
-\ General info:
-\ Classes are objects, too: all classes are instances of METACLASS
-\ All classes are derived (by convention) from OBJECT. This
-\ base class provides a default initializer and superclass
-\ access method
-
-\ A ficl object binds instance storage (payload) to a class.
-\ object ( -- instance class )
-\ All objects push their payload address and class address when
-\ executed.
-
-\ A ficl class consists of a parent class pointer, a wordlist
-\ ID for the methods of the class, and a size for the payload
-\ of objects created by the class. A class is an object.
-\ The NEW method creates and initializes an instance of a class.
-\ Classes have this footprint:
-\ cell 0: parent class address
-\ cell 1: wordlist ID
-\ cell 2: size of instance's payload
-
-\ Methods expect an object couple ( instance class )
-\ on the stack. This is by convention - ficl has no way to
-\ police your code to make sure this is always done, but it
-\ happens naturally if you use the facilities presented here.
-\
-\ Overridden methods must maintain the same stack signature as
-\ their predecessors. Ficl has no way of enforcing this, either.
-\
-\ Revised Apr 2001 - Added Guy Carver's vtable extensions. Class now
-\ has an extra field for the vtable method count. Hasvtable declares
-\ refs to vtable classes
-\
-\ Revised 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...
-\
-
-hide
-
-\ p a r s e - m e t h o d
-\ compiles a method name so that it pushes
-\ the string base address and count at run-time.
-
-: parse-method \ name run: ( -- c-addr u )
- parse-word
- postpone sliteral
-; compile-only
-
-\ l o o k u p - m e t h o d
-\ takes a counted string method name from the stack (as compiled
-\ by parse-method) and attempts to look this method up in the method list of
-\ the class that's on the stack. If successful, it leaves the class on the stack
-\ and pushes the xt of the method. If not, it aborts with an error message.
-
-: lookup-method { class 2:name -- class xt }
- name class cell+ @ ( c-addr u wid )
- search-wordlist ( 0 | xt 1 | xt -1 )
- 0= if
- name type ." not found in "
- class body> >name type
- cr abort
- endif
- class swap
-;
-
-: find-method-xt \ name ( class -- class xt )
- parse-word lookup-method
-;
-
-set-current ( stop hiding definitions )
-
-: catch-method ( instance class c-addr u -- <method-signature> exc-flag )
- lookup-method catch
-;
-
-: exec-method ( instance class c-addr u -- <method-signature> )
- lookup-method execute
-;
-
-\ Method lookup operator takes a class-addr and instance-addr
-\ and executes the method from the class's wordlist if
-\ interpreting. If compiling, bind late.
-\
-: --> ( instance class -- ??? )
- state @ 0= if
- find-method-xt execute
- else
- parse-method postpone exec-method
- endif
-; immediate
-
-\ Method lookup with CATCH in case of exceptions
-: c-> ( instance class -- ?? exc-flag )
- state @ 0= if
- find-method-xt catch
- else
- parse-method postpone catch-method
- endif
-; immediate
-
-\ METHOD makes global words that do method invocations by late binding
-\ in case you prefer this style (no --> in your code)
-\ Example: everything has next and prev for array access, so...
-\ method next
-\ method prev
-\ my-instance next ( does whatever next does to my-instance by late binding )
-
-: method create does> body> >name lookup-method execute ;
-
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-\ ** E A R L Y B I N D I N G
-\ Early binding operator compiles code to execute a method
-\ given its class at compile time. Classes are immediate,
-\ so they leave their cell-pair on the stack when compiling.
-\ Example:
-\ : get-wid metaclass => .wid @ ;
-\ Usage
-\ my-class get-wid ( -- wid-of-my-class )
-\
-1 ficl-named-wordlist instance-vars
-instance-vars dup >search ficl-set-current
-
-: => \ c:( class meta -- ) run: ( -- ??? ) invokes compiled method
- drop find-method-xt compile, drop
-; immediate compile-only
-
-: my=> \ c:( -- ) run: ( -- ??? ) late bind compiled method of current-class
- current-class @ dup postpone =>
-; immediate compile-only
-
-\ 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
\ No newline at end of file
--- a/softwords/prefix.fr
+++ /dev/null
@@ -1,57 +1,0 @@
-\ **
-\ ** Prefix words for ficl
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-\ (jws) To make a prefix, simply create a new definition in the <prefixes>
-\ wordlist. start-prefixes and end-prefixes handle the bookkeeping
-
-variable save-current
-
-: start-prefixes get-current save-current ! <prefixes> set-current ;
-: end-prefixes save-current @ set-current ;
-: show-prefixes <prefixes> >search words search> drop ;
-
-\ #if (FICL_EXTENDED_PREFIX)
-
-start-prefixes
-
-\ define " (double-quote) as an alias for s", and make it a prefix
-: " postpone s" ; immediate
-
-
-\ make .( a prefix (we just create an alias for it in the prefixes list)
-: .( .( ;
-
-
-\ 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
--- a/softwords/softcore.bat
+++ /dev/null
@@ -1,1 +1,0 @@
-perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
--- a/softwords/softcore.fr
+++ /dev/null
@@ -1,207 +1,0 @@
-\ ** ficl/softwords/softcore.fr
-\ ** FICL soft extensions
-\ ** John Sadler (john_sadler@alum.mit.edu)
-\ ** September, 1998
-
-\ ** Ficl USER variables
-\ ** See words.c for primitive def'n of USER
-.( loading ficl soft extensions ) cr
-\ #if FICL_WANT_USER
-variable nUser 0 nUser !
-: user \ name ( -- )
- nUser dup @ user 1 swap +! ;
-
-\ #endif
-
-\ ** ficl extras
-\ EMPTY cleans the parameter stack
-: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
-\ CELL- undoes CELL+
-: cell- ( addr -- addr ) [ 1 cells ] literal - ;
-: -rot ( a b c -- c a b ) 2 -roll ;
-
-\ ** CORE
-: abs ( x -- x )
- dup 0< if negate endif ;
-decimal 32 constant bl
-
-: space ( -- ) bl emit ;
-
-: spaces ( n -- ) 0 ?do space loop ;
-
-: abort"
- state @ if
- postpone if
- postpone ."
- postpone cr
- -2
- postpone literal
- postpone throw
- postpone endif
- else
- [char] " parse
- rot if
- type
- cr
- -2 throw
- else
- 2drop
- endif
- endif
-; immediate
-
-
-\ ** CORE EXT
-.( loading CORE EXT words ) cr
-0 constant false
-false invert constant true
-: <> = 0= ;
-: 0<> 0= 0= ;
-: compile, , ;
-: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
-: erase ( addr u -- ) 0 fill ;
-variable span
-: expect ( c-addr u1 -- ) accept span ! ;
-\ see marker.fr for MARKER implementation
-: nip ( y x -- x ) swap drop ;
-: tuck ( y x -- x y x) swap over ;
-: within ( test low high -- flag ) over - >r - r> u< ;
-
-
-\ ** LOCAL EXT word set
-\ #if FICL_WANT_LOCALS
-: locals| ( name...name | -- )
- begin
- bl word count
- dup 0= abort" where's the delimiter??"
- over c@
- [char] | - over 1- or
- while
- (local)
- repeat 2drop 0 0 (local)
-; immediate
-
-: local ( name -- ) bl word count (local) ; immediate
-
-: 2local ( name -- ) bl word count (2local) ; immediate
-
-: end-locals ( -- ) 0 0 (local) ; immediate
-
-\ #endif
-
-\ ** TOOLS word set...
-: ? ( addr -- ) @ . ;
-: dump ( addr u -- )
- 0 ?do
- dup c@ . 1+
- i 7 and 7 = if cr endif
- loop drop
-;
-
-\ ** SEARCH+EXT words and ficl helpers
-.( loading SEARCH & SEARCH-EXT words ) cr
-\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
-\ wordlist dup create , brand-wordlist
-\ gets the name of the word made by create and applies it to the wordlist...
-: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
-
-: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
- ficl-wordlist dup create , brand-wordlist does> @ ;
-
-: wordlist ( -- )
- 1 ficl-wordlist ;
-
-\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
-: ficl-set-current ( wid -- old-wid )
- get-current swap set-current ;
-
-\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
-\ When executed, new voc replaces top of search stack
-: do-vocabulary ( -- )
- does> @ search> drop >search ;
-
-: ficl-vocabulary ( nBuckets name -- )
- ficl-named-wordlist do-vocabulary ;
-
-: vocabulary ( name -- )
- 1 ficl-vocabulary ;
-
-\ PREVIOUS drops the search order stack
-: previous ( -- ) search> drop ;
-
-\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
-\ USAGE:
-\ hide
-\ <definitions to hide>
-\ set-current
-\ <words that use hidden defs>
-\ previous ( pop HIDDEN off the search order )
-
-1 ficl-named-wordlist hidden
-: hide hidden dup >search ficl-set-current ;
-
-\ ALSO dups the search stack...
-: also ( -- )
- search> dup >search >search ;
-
-\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
-: forth ( -- )
- search> drop
- forth-wordlist >search ;
-
-\ ONLY sets the search order to a default state
-: only ( -- )
- -1 set-order ;
-
-\ ORDER displays the compile wid and the search order list
-hide
-: list-wid ( wid -- )
- dup wid-get-name ( wid c-addr u )
- ?dup if
- type drop
- else
- drop ." (unnamed wid) " x.
- endif cr
-;
-set-current \ stop hiding words
-
-: order ( -- )
- ." Search:" cr
- get-order 0 ?do 3 spaces list-wid loop cr
- ." Compile: " get-current list-wid cr
-;
-
-: debug ' debug-xt ; immediate
-: on-step ." S: " .s cr ;
-
-
-\ Submitted by lch.
-: strdup ( c-addr length -- c-addr2 length2 ior )
- 0 locals| addr2 length c-addr | end-locals
- length 1 + allocate
- 0= if
- to addr2
- c-addr addr2 length move
- addr2 length 0
- else
- 0 -1
- endif
- ;
-
-: strcat ( 2:a 2:b -- 2:new-a )
- 0 locals| b-length b-u b-addr a-u a-addr | end-locals
- b-u to b-length
- b-addr a-addr a-u + b-length move
- a-addr a-u b-length +
- ;
-
-: strcpy ( 2:a 2:b -- 2:new-a )
- locals| b-u b-addr a-u a-addr | end-locals
- a-addr 0 b-addr b-u strcat
- ;
-
-
-previous \ lose hidden words from search order
-
-\ ** E N D S O F T C O R E . F R
-
--- a/softwords/softcore.pl
+++ /dev/null
@@ -1,144 +1,0 @@
-#! /usr/bin/perl
-# Convert forth source files to a giant C string
-
-$now = localtime;
-
-print <<EOF
-/*******************************************************************
-** s o f t c o r e . c
-** Forth Inspired Command Language -
-** Words from CORE set written in FICL
-** Author: John Sadler (john_sadler\@alum.mit.edu)
-** Created: 27 December 1997
-** Last update: $now
-*******************************************************************/
-/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
-** Make changes to the .fr files in ficl/softwords instead.
-** This file contains definitions that are compiled into the
-** system dictionary by the first virtual machine to be created.
-** Created automagically by ficl/softwords/softcore.pl
-*/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler\@alum.mit.edu)
-** All rights reserved.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** I am interested in hearing from anyone who uses ficl. If you have
-** a problem, a success story, a defect, an enhancement request, or
-** if you would like to contribute to the ficl release, please send
-** contact me by email at the address above.
-**
-** L I C E N S E and D I S C L A I M E R
-**
-** Redistribution and use in source and binary forms, with or without
-** modification, are permitted provided that the following conditions
-** are met:
-** 1. Redistributions of source code must retain the above copyright
-** notice, this list of conditions and the following disclaimer.
-** 2. Redistributions in binary form must reproduce the above copyright
-** notice, this list of conditions and the following disclaimer in the
-** documentation and/or other materials provided with the distribution.
-**
-** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-** SUCH DAMAGE.
-*/
-
-
-#include "ficl.h"
-
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS
-EOF
-;
-
-$commenting = 0;
-
-while (<>) {- s"\n$""; # remove EOL
- s/\"/\\\"/g; # escape quotes
-
- #
- # emit lines beginnning with "\ **" as C comments
- #
- if (/^\\\s\*\*/) { - s"^\\ "";
- if ($commenting == 0) {- print "/*\n";
- }
- $commenting = 1;
- print "$_\n";
- next;
- }
-
- if ($commenting == 1) {- print "*/\n";
- }
-
- $commenting = 0;
-
- #
- # ignore empty lines and lines containing
- # only empty comments
- #
- next if /^\s*\\\s*$/;
- next if /^\s*$/;
-
- #
- # pass commented preprocessor directives
- # == lines starting with "\ #"
- # (supports single line directives only)
- #
- if (/^\\\s#/) {- s"^\\ "";
- print "$_\n";
- next;
- }
-
- next if /^\s*\\ /; # toss all other \ comment lines
- s"\\\s+.*$"" ; # lop off trailing \ comments
- s"\s+\(\s.*?\)""g; # delete ( ) comments
- s"^\s+""; # remove leading spaces
- s"\s+$""; # remove trailing spaces
-
- #
- # emit whatever's left as quoted string fragments
- #
-# $out = " \"" . $_ . " \\n\"";
- $out = " \"" . $_ . " \"";
- print "$out\n";
-}
-
-print <<EOF
-#endif /* WANT_SOFTWORDS */
- "quit ";
-
-
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
-{- FICL_VM *pVM = pSys->vmList;
- CELL id = pVM->sourceID;
- int ret = sizeof (softWords);
- assert(pVM);
- pVM->sourceID.i = -1;
- ret = ficlExec(pVM, softWords);
- pVM->sourceID = id;
- if (ret == VM_ERREXIT)
- assert(FALSE);
- return;
-}
-
-
-EOF
-;
-
--- a/softwords/softcore.py
+++ /dev/null
@@ -1,152 +1,0 @@
-#! python
-# Convert forth source files to a giant C string
-
-import re;
-import sys;
-import time;
-
-
-print """/*******************************************************************
-** s o f t c o r e . c
-** Forth Inspired Command Language -
-** Words from CORE set written in FICL
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 27 December 1997
-** Last update: """ + time.ctime(time.time()) + """
-*******************************************************************/
-/*
-** DO NOT EDIT THIS FILE -- it is generated by softwords/softcore.pl
-** Make changes to the .fr files in ficl/softwords instead.
-** This file contains definitions that are compiled into the
-** system dictionary by the first virtual machine to be created.
-** Created automagically by ficl/softwords/softcore.pl
-*/
-/*
-** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
-** All rights reserved.
-**
-** Get the latest Ficl release at http://ficl.sourceforge.net
-**
-** I am interested in hearing from anyone who uses ficl. If you have
-** a problem, a success story, a defect, an enhancement request, or
-** if you would like to contribute to the ficl release, please send
-** contact me by email at the address above.
-**
-** L I C E N S E and D I S C L A I M E R
-**
-** Redistribution and use in source and binary forms, with or without
-** modification, are permitted provided that the following conditions
-** are met:
-** 1. Redistributions of source code must retain the above copyright
-** notice, this list of conditions and the following disclaimer.
-** 2. Redistributions in binary form must reproduce the above copyright
-** notice, this list of conditions and the following disclaimer in the
-** documentation and/or other materials provided with the distribution.
-**
-** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-** SUCH DAMAGE.
-*/
-
-
-#include "ficl.h"
-
-static char softWords[] =
-#if FICL_WANT_SOFTWORDS"""
-
-escapedQuotes = re.compile( r'^"(.*)"$' )
-backslash = re.compile( r'^(.*[^\s])\s+\\(\s+[^\s].*)$' )
-parentheses = re.compile( r'^(.*[^\s])\s+\(\s[^)]+\)(\s+[^\s].*)?$' )
-
-
-commenting = 0;
-
-for a in (sys.argv[1:]):
- f = open(a)
- for line in f.readlines():
-
- # trim all whitespace
- line = line.strip();
-
- # remove quotes around quoted lines
- quoted = escapedQuotes.match(line)
- if (quoted != None):
- line = quoted.group(1).strip()
-
- #
- # emit lines beginnning with "\ **" as C comments
- #
- if (line[0:4] == "\\ **"):
- if (commenting == 0):
- print("/*")- commenting = 1
- print(line[2:])
- continue
-
- if (commenting == 1):
- print "*/"
-
- commenting = 0
-
- # ignore empty lines
- if (len(line) == 0):
- continue
-
- # pass commented preprocessor directives
- # == lines starting with "\ #"
- # (supports single line directives only)
- if (line[0:3] == "\\ #"):
- print(line[2:]) # include the leading #!
- continue
-
- # ignore remaining lines starting with comments
- if (line[0] == "\\"):
- continue
-
- # remove trailing comments
- trailingComment = backslash.match(line)
- if (trailingComment != None):
- line = trailingComment.group(1)
-
- # remove ( comments ) in the middle
- embeddedComment = parentheses.match(line)
- if (embeddedComment != None):
- line = embeddedComment.group(1)
- if (embeddedComment.lastindex >= 2):
- line = line + " " + embeddedComment.group(2).strip()
-
- # quote double-quote characters
- line = line.replace("\"", "\\\"")-
- # emit whatever's left as quoted string fragments
- print(" \"" + line + " \"");-
-
-print """#endif /* WANT_SOFTWORDS */
- "quit ";
-
-
-void ficlCompileSoftCore(FICL_SYSTEM *pSys)
-{- FICL_VM *pVM = pSys->vmList;
- CELL id = pVM->sourceID;
- int ret = sizeof (softWords);
- assert(pVM);
- pVM->sourceID.i = -1;
- ret = ficlExec(pVM, softWords);
- pVM->sourceID = id;
- if (ret == VM_ERREXIT)
- assert(FALSE);
- return;
-}
-
-
-"""
--- a/softwords/softcore.py.bat
+++ /dev/null
@@ -1,1 +1,0 @@
-python softcore.py softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr fileaccess.fr >..\softcore.c
--- a/softwords/string.fr
+++ /dev/null
@@ -1,148 +1,0 @@
-\ #if (FICL_WANT_OOP)
-\ ** ficl/softwords/string.fr
-\ A useful dynamic string class
-\ John Sadler 14 Sep 1998
-\
-\ ** C - S T R I N G
-\ counted string, buffer sized dynamically
-\ Creation example:
-\ c-string --> new str
-\ s" arf arf!!" str --> set
-\ s" woof woof woof " str --> cat
-\ str --> type cr
-\
-
-.( loading ficl string class ) cr
-also oop definitions
-
-object subclass c-string
- c-cell obj: .count
- c-cell obj: .buflen
- c-ptr obj: .buf
- 32 constant min-buf
-
- : get-count ( 2:this -- count ) my=[ .count get ] ;
- : set-count ( count 2:this -- ) my=[ .count set ] ;
-
- : ?empty ( 2:this -- flag ) --> get-count 0= ;
-
- : get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
- : set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
-
- : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;
- : set-buf { ptr len 2:this -- }
- ptr this my=[ .buf set-ptr ]
- len this my=> set-buflen
- ;
-
- \ set buffer to null and buflen to zero
- : clr-buf ( 2:this -- )
- 0 0 2over my=> set-buf
- 0 -rot my=> set-count
- ;
-
- \ free the buffer if there is one, set buf pointer to null
- : free-buf { 2:this -- }
- this my=> get-buf
- ?dup if
- free
- abort" c-string free failed"
- this my=> clr-buf
- endif
- ;
-
- \ guarantee buffer is large enough to hold size chars
- : size-buf { size 2:this -- }
- size 0< abort" need positive size for size-buf"
- size 0= if
- this --> free-buf exit
- endif
-
- \ force buflen to be a positive multiple of min-buf chars
- my=> min-buf size over / 1+ * chars to size
-
- \ if buffer is null, allocate one, else resize it
- this --> get-buflen 0=
- if
- size allocate
- abort" out of memory"
- size this --> set-buf
- size this --> set-buflen
- exit
- endif
-
- size this --> get-buflen > if
- this --> get-buf size resize
- abort" out of memory"
- size this --> set-buf
- endif
- ;
-
- : set { c-addr u 2:this -- }
- u this --> size-buf
- u this --> set-count
- c-addr this --> get-buf u move
- ;
-
- : get { 2:this -- c-addr u }
- this --> get-buf
- this --> get-count
- ;
-
- \ append string to existing one
- : cat { c-addr u 2:this -- }
- this --> get-count u + dup >r
- this --> size-buf
- c-addr this --> get-buf this --> get-count + u move
- r> this --> set-count
- ;
-
- : type { 2:this -- }
- this --> ?empty if ." (empty) " exit endif
- this --> .buf --> get-ptr
- this --> .count --> get
- type
- ;
-
- : compare ( 2string 2:this -- n )
- --> get
- 2swap
- --> get
- 2swap compare
- ;
-
- : hashcode ( 2:this -- hashcode )
- --> get hash
- ;
-
- \ destructor method (overrides object --> free)
- : free ( 2:this -- ) 2dup --> free-buf object => free ;
-
-end-class
-
-c-string subclass c-hashstring
- c-2byte obj: .hashcode
-
- : set-hashcode { 2:this -- }
- this --> super --> hashcode
- this --> .hashcode --> set
- ;
-
- : get-hashcode ( 2:this -- hashcode )
- --> .hashcode --> get
- ;
-
- : set ( c-addr u 2:this -- )
- 2swap 2over --> super --> set
- --> set-hashcode
- ;
-
- : cat ( c-addr u 2:this -- )
- 2swap 2over --> super --> cat
- --> set-hashcode
- ;
-
-end-class
-
-previous definitions
-\ #endif
--- a/softwords/win32.fr
+++ /dev/null
@@ -1,10 +1,0 @@
-\ **
-\ ** win32.fr
-\ ** submitted by Larry Hastings, larry@hastings.org
-\ **
-
-
-\ ** simple wrappers for callnativeFunction that specify the calling convention
-: callcfunction 1 callnativeFunction ;
-: callpascalfunction 0 callnativeFunction ;
-
--- a/stack.c
+++ b/stack.c
@@ -1,367 +1,416 @@
-/*******************************************************************
-** 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.
-*/
-
-#include <stdlib.h>
-
-#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;
-}
-
-
+/*******************************************************************
+** 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.11 2010/08/12 13:57:22 asau Exp $
+*******************************************************************/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <stdlib.h>
+
+#include "ficl.h"
+
+#define STKDEPTH(s) (((s)->top - (s)->base) + 1)
+
+/*
+** N O T E: Stack convention:
+**
+** THIS CHANGED IN FICL 4.0!
+**
+** top points to the *current* top data value
+** push: increment top, store value at top
+** pop: fetch value at top, decrement top
+** Stack grows from low to high memory
+*/
+
+/*******************************************************************
+ v m C h e c k S t a c k
+** Check the parameter stack for underflow or overflow.
+** size controls the type of check: if size is zero,
+** the function checks the stack state for underflow and overflow.
+** If size > 0, checks to see that the stack has room to push
+** that many cells. If less than zero, checks to see that the
+** stack has room to pop that many cells. If any test fails,
+** the function throws (via vmThrow) a VM_ERREXIT exception.
+*******************************************************************/
+void ficlStackCheck(ficlStack *stack, int popCells, int pushCells)
+#if FICL_ROBUST >= 1
+{+ int nFree = stack->size - STKDEPTH(stack);
+
+ if (popCells > STKDEPTH(stack))
+ {+ ficlVmThrowError(stack->vm, "Error: %s stack underflow", stack->name);
+ }
+
+ if (nFree < pushCells - popCells)
+ {+ ficlVmThrowError(stack->vm, "Error: %s stack overflow", stack->name);
+ }
+
+ return;
+}
+#else /* FICL_ROBUST >= 1 */
+{+ FICL_IGNORE(stack);
+ FICL_IGNORE(popCells);
+ FICL_IGNORE(pushCells);
+}
+#endif /* FICL_ROBUST >= 1 */
+
+/*******************************************************************
+ s t a c k C r e a t e
+**
+*******************************************************************/
+
+ficlStack *ficlStackCreate(ficlVm *vm, char *name, unsigned size)
+{+ size_t totalSize = sizeof (ficlStack) + (size * sizeof (ficlCell));
+ ficlStack *stack = ficlMalloc(totalSize);
+
+ FICL_VM_ASSERT(vm, size != 0);
+ FICL_VM_ASSERT(vm, stack != NULL);
+
+ stack->size = size;
+ stack->frame = NULL;
+
+ stack->vm = vm;
+ stack->name = name;
+
+ ficlStackReset(stack);
+ return stack;
+}
+
+
+/*******************************************************************
+ s t a c k D e l e t e
+**
+*******************************************************************/
+
+void ficlStackDestroy(ficlStack *stack)
+{+ if (stack)
+ ficlFree(stack);
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k D e p t h
+**
+*******************************************************************/
+
+int ficlStackDepth(ficlStack *stack)
+{+ return STKDEPTH(stack);
+}
+
+/*******************************************************************
+ s t a c k D r o p
+**
+*******************************************************************/
+
+void ficlStackDrop(ficlStack *stack, int n)
+{+ FICL_VM_ASSERT(stack->vm, n > 0);
+ stack->top -= n;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k F e t c h
+**
+*******************************************************************/
+
+ficlCell ficlStackFetch(ficlStack *stack, int n)
+{+ return stack->top[-n];
+}
+
+void ficlStackStore(ficlStack *stack, int n, ficlCell c)
+{+ stack->top[-n] = c;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k G e t T o p
+**
+*******************************************************************/
+
+ficlCell ficlStackGetTop(ficlStack *stack)
+{+ return stack->top[0];
+}
+
+#if FICL_WANT_LOCALS
+
+/*******************************************************************
+ s t a c k L i n k
+** Link a frame using the stack's frame pointer. Allot space for
+** size cells in the frame
+** 1) Push frame
+** 2) frame = top
+** 3) top += size
+*******************************************************************/
+
+void ficlStackLink(ficlStack *stack, int size)
+{+ ficlStackPushPointer(stack, stack->frame);
+ stack->frame = stack->top + 1;
+ stack->top += size;
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k U n l i n k
+** Unink a stack frame previously created by stackLink
+** 1) top = frame
+** 2) frame = pop()
+*******************************************************************/
+
+void ficlStackUnlink(ficlStack *stack)
+{+ stack->top = stack->frame - 1;
+ stack->frame = ficlStackPopPointer(stack);
+ return;
+}
+#endif /* FICL_WANT_LOCALS */
+
+
+/*******************************************************************
+ s t a c k P i c k
+**
+*******************************************************************/
+
+void ficlStackPick(ficlStack *stack, int n)
+{+ ficlStackPush(stack, ficlStackFetch(stack, n));
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k P o p
+**
+*******************************************************************/
+
+ficlCell ficlStackPop(ficlStack *stack)
+{+ return *stack->top--;
+}
+
+void *ficlStackPopPointer(ficlStack *stack)
+{+ return (*stack->top--).p;
+}
+
+ficlUnsigned ficlStackPopUnsigned(ficlStack *stack)
+{+ return (*stack->top--).u;
+}
+
+ficlInteger ficlStackPopInteger(ficlStack *stack)
+{+ return (*stack->top--).i;
+}
+
+ficl2Integer ficlStackPop2Integer(ficlStack *stack)
+{+ ficl2Integer ret;
+ ficlInteger high = ficlStackPopInteger(stack);
+ ficlInteger low = ficlStackPopInteger(stack);
+ FICL_2INTEGER_SET(high, low, ret);
+ return ret;
+}
+
+ficl2Unsigned ficlStackPop2Unsigned(ficlStack *stack)
+{+ ficl2Unsigned ret;
+ ficlUnsigned high = ficlStackPopUnsigned(stack);
+ ficlUnsigned low = ficlStackPopUnsigned(stack);
+ FICL_2UNSIGNED_SET(high, low, ret);
+ return ret;
+}
+
+
+#if (FICL_WANT_FLOAT)
+ficlFloat ficlStackPopFloat(ficlStack *stack)
+{+ return (*stack->top--).f;
+}
+#endif
+
+
+/*******************************************************************
+ s t a c k P u s h
+**
+*******************************************************************/
+
+void ficlStackPush(ficlStack *stack, ficlCell c)
+{+ *++stack->top = c;
+}
+
+void ficlStackPushPointer(ficlStack *stack, void *ptr)
+{+ *++stack->top = FICL_LVALUE_TO_CELL(ptr);
+}
+
+void ficlStackPushInteger(ficlStack *stack, ficlInteger i)
+{+ *++stack->top = FICL_LVALUE_TO_CELL(i);
+}
+
+void ficlStackPushUnsigned(ficlStack *stack, ficlUnsigned u)
+{+ *++stack->top = FICL_LVALUE_TO_CELL(u);
+}
+
+void ficlStackPush2Unsigned(ficlStack *stack, ficl2Unsigned du)
+{+ ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_LOW(du));
+ ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_HIGH(du));
+ return;
+}
+
+void ficlStackPush2Integer(ficlStack *stack, ficl2Integer di)
+{+ ficlStackPush2Unsigned(stack, FICL_2INTEGER_TO_2UNSIGNED(di));
+ return;
+}
+
+#if (FICL_WANT_FLOAT)
+void ficlStackPushFloat(ficlStack *stack, ficlFloat f)
+{+ *++stack->top = FICL_LVALUE_TO_CELL(f);
+}
+#endif
+
+
+/*******************************************************************
+ s t a c k R e s e t
+**
+*******************************************************************/
+
+void ficlStackReset(ficlStack *stack)
+{+ stack->top = stack->base - 1;
+ 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 ficlStackRoll(ficlStack *stack, int n)
+{+ ficlCell c;
+ ficlCell *cell;
+
+ if (n == 0)
+ return;
+ else if (n > 0)
+ {+ cell = stack->top - n;
+ c = *cell;
+
+ for (;n > 0; --n, cell++)
+ {+ *cell = cell[1];
+ }
+
+ *cell = c;
+ }
+ else
+ {+ cell = stack->top;
+ c = *cell;
+
+ for (; n < 0; ++n, cell--)
+ {+ *cell = cell[-1];
+ }
+
+ *cell = c;
+ }
+ return;
+}
+
+
+/*******************************************************************
+ s t a c k S e t T o p
+**
+*******************************************************************/
+
+void ficlStackSetTop(ficlStack *stack, ficlCell c)
+{+ FICL_STACK_CHECK(stack, 1, 1);
+ stack->top[0] = c;
+ return;
+}
+
+
+
+
+void ficlStackWalk(ficlStack *stack, ficlStackWalkFunction callback, void *context, ficlInteger bottomToTop)
+{+ int i;
+ int depth;
+ ficlCell *cell;
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ depth = ficlStackDepth(stack);
+ cell = bottomToTop ? stack->base : stack->top;
+ for (i = 0; i < depth; i++)
+ {+ if (callback(context, cell) == FICL_FALSE)
+ break;
+ cell += bottomToTop ? 1 : -1;
+ }
+ return;
+}
+
+
--- a/sysdep.c
+++ /dev/null
@@ -1,409 +1,0 @@
-/*******************************************************************
-** s y s d e p . c
-** Forth Inspired Command Language
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 16 Oct 1997
-** Implementations of FICL external interface functions...
-**
-** (simple) port to Linux, Skip Carter 26 March 1998
-** $Id: sysdep.c,v 1.12 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.
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-
-#include "ficl.h"
-
-/*
-******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
-*/
-#if defined (FREEBSD_ALPHA)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- u_int64_t qx;
-
- qx = (u_int64_t)x * (u_int64_t) y;
-
- q.hi = (u_int32_t)( qx >> 32 );
- q.lo = (u_int32_t)( qx & 0xFFFFFFFFL);
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- u_int64_t qx, qh;
-
- qh = q.hi;
- qx = (qh << 32) | q.lo;
-
- result.quot = qx / y;
- result.rem = qx % y;
-
- return result;
-}
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- while(*msg != 0)
- putchar(*(msg++));
- if (fNewline)
- putchar('\n');
-
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-void *ficlRealloc (void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-/*
-******************* P C / W I N 3 2 P O R T B E G I N S H E R E ***********************
-*/
-#elif defined (_M_IX86)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
-
- __asm
- {
- mov eax,x
- mov edx,y
- mul edx
- mov q.hi,edx
- mov q.lo,eax
- }
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
-
- __asm
- {
- mov eax,q.lo
- mov edx,q.hi
- div y
- mov result.quot,eax
- mov result.rem,edx
- }
-
- return result;
-}
-
-#endif
-
-#if !defined (_WINDOWS)
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- if (fNewline)
- puts(msg);
- else
- fputs(msg, stdout);
-
- return;
-}
-
-#endif
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-
-void *ficlRealloc(void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-/*
-******************* 6 8 K C P U 3 2 P O R T B E G I N S H E R E ********************
-*/
-#elif defined (MOTO_CPU32)
-
-#if PORTABLE_LONGMULDIV == 0
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- IGNORE(q); /* suppress goofy compiler warnings */
- IGNORE(x);
- IGNORE(y);
-
-#pragma ASM
- move.l (S_x,a6),d1
- mulu.l (S_y,a6),d0:d1
- move.l d1,(S_q+4,a6)
- move.l d0,(S_q+0,a6)
-#pragma END_ASM
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- IGNORE(result); /* suppress goofy compiler warnings */
- IGNORE(q);
- IGNORE(y);
-
-#pragma ASM
- move.l (S_q+0,a6),d0 ; hi 32 --> d0
- move.l (S_q+4,a6),d1 ; lo 32 --> d1
- divu.l (S_y,a6),d0:d1 ; d0 <-- rem, d1 <-- quot
- move.l d1,(S_result+0,a6)
- move.l d0,(S_result+4,a6)
-#pragma END_ASM
-
- return result;
-}
-
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
-}
-
-void ficlFree (void *p)
-{
-}
-
-
-void *ficlRealloc(void *p, size_t size)
-{
- void *pv = malloc(size);
- if (p)
- {
- memcpy(pv, p, size)
- free(p);
- }
-
- return pv;
-}
-
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-#endif /* MOTO_CPU32 */
-
-/*
-******************* Linux P O R T B E G I N S H E R E ******************** Skip Carter, March 1998
-*/
-
-#if defined(linux) || defined(riscos)
-
-#if PORTABLE_LONGMULDIV == 0
-
-typedef unsigned long long __u64;
-typedef unsigned long __u32;
-
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
-{
- DPUNS q;
- __u64 qx;
-
- qx = (__u64)x * (__u64) y;
-
- q.hi = (__u32)( qx >> 32 );
- q.lo = (__u32)( qx & 0xFFFFFFFFL);
-
- return q;
-}
-
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
-{
- UNSQR result;
- __u64 qx, qh;
-
- qh = q.hi;
- qx = (qh << 32) | q.lo;
-
- result.quot = qx / y;
- result.rem = qx % y;
-
- return result;
-}
-
-#endif
-
-void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
-{
- IGNORE(pVM);
-
- if (fNewline)
- puts(msg);
- else
- fputs(msg, stdout);
-
- return;
-}
-
-void *ficlMalloc (size_t size)
-{
- return malloc(size);
-}
-
-void ficlFree (void *p)
-{
- free(p);
-}
-
-void *ficlRealloc(void *p, size_t size)
-{
- return realloc(p, size);
-}
-
-
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** is guaranteed to be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** befor timeout (optional - could also block forever)
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock)
-{
- IGNORE(fLock);
- return 0;
-}
-#endif /* FICL_MULTITHREAD */
-
-#endif /* linux */
-
-
--- a/sysdep.h
+++ /dev/null
@@ -1,465 +1,0 @@
-/*******************************************************************
- s y s d e p . h
-** Forth Inspired Command Language
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 16 Oct 1997
-** Ficl system dependent types and prototypes...
-**
-** Note: Ficl also depends on the use of "assert" when
-** FICL_ROBUST is enabled. This may require some consideration
-** in firmware systems since assert often
-** assumes stderr/stdout.
-** $Id: sysdep.h,v 1.11 2001/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.
-*/
-
-#if !defined (__SYSDEP_H__)
-#define __SYSDEP_H__
-
-#include <stddef.h> /* size_t, NULL */
-#include <setjmp.h>
-#include <assert.h>
-
-#if defined(_WIN32)
- #include <stdio.h>
- #ifndef alloca
- #define alloca(x) _alloca(x)
- #endif /* alloca */
- #define fstat _fstat
- #define stat _stat
- #define getcwd _getcwd
- #define chdir _chdir
- #define unlink _unlink
- #define fileno _fileno
-
- #define FICL_HAVE_FTRUNCATE 1
- extern int ftruncate(int fileno, size_t size);
-#elif defined(linux)
- #define FICL_HAVE_FTRUNCATE 1
-#endif /* platform */
-
-#if !defined IGNORE /* Macro to silence unused param warnings */
-#define IGNORE(x) &x
-#endif
-
-/*
-** TRUE and FALSE for C boolean operations, and
-** portable 32 bit types for CELLs
-**
-*/
-#if !defined TRUE
-#define TRUE 1
-#endif
-#if !defined FALSE
-#define FALSE 0
-#endif
-
-/*
-** FreeBSD Alpha (64 bit) data types
-*/
-#if defined (FREEBSD_ALPHA)
-
-#define INT32 int
-#define UNS32 unsigned int
-#define FICL_INT long
-#define FICL_UNS unsigned long
-#define BITS_PER_CELL 64
-#define FICL_ALIGN 3
-#endif
-
-/*
-** System dependent data type declarations...
-*/
-#if !defined INT32
-#define INT32 long
-#endif
-
-#if !defined UNS32
-#define UNS32 unsigned long
-#endif
-
-#if !defined UNS16
-#define UNS16 unsigned short
-#endif
-
-#if !defined UNS8
-#define UNS8 unsigned char
-#endif
-
-#if !defined NULL
-#define NULL ((void *)0)
-#endif
-
-/*
-** FICL_UNS and FICL_INT must have the same size as a void* on
-** the target system. A CELL is a union of void*, FICL_UNS, and
-** FICL_INT.
-** (11/2000: same for FICL_FLOAT)
-*/
-#if !defined FICL_INT
-#define FICL_INT INT32
-#endif
-
-#if !defined FICL_UNS
-#define FICL_UNS UNS32
-#endif
-
-#if !defined FICL_FLOAT
-#define FICL_FLOAT float
-#endif
-
-/*
-** Ficl presently supports values of 32 and 64 for BITS_PER_CELL
-*/
-#if !defined BITS_PER_CELL
-#define BITS_PER_CELL 32
-#endif
-
-#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64))
- Error!
-#endif
-
-typedef struct
-{
- FICL_UNS hi;
- FICL_UNS lo;
-} DPUNS;
-
-typedef struct
-{
- FICL_UNS quot;
- FICL_UNS rem;
-} UNSQR;
-
-typedef struct
-{
- FICL_INT hi;
- FICL_INT lo;
-} DPINT;
-
-typedef struct
-{
- FICL_INT quot;
- FICL_INT rem;
-} INTQR;
-
-
-/*
-** B U I L D C O N T R O L S
-*/
-
-#if !defined (FICL_MINIMAL)
-#define FICL_MINIMAL 0
-#endif
-#if (FICL_MINIMAL)
-#define FICL_WANT_SOFTWORDS 0
-#define FICL_WANT_FILE 0
-#define FICL_WANT_FLOAT 0
-#define FICL_WANT_USER 0
-#define FICL_WANT_LOCALS 0
-#define FICL_WANT_DEBUGGER 0
-#define FICL_WANT_OOP 0
-#define FICL_PLATFORM_EXTEND 0
-#define FICL_MULTITHREAD 0
-#define FICL_ROBUST 0
-#define FICL_EXTENDED_PREFIX 0
-#endif
-
-/*
-** FICL_PLATFORM_EXTEND
-** Includes words defined in ficlCompilePlatform (see win32.c and unix.c for example)
-*/
-#if defined (_WIN32)
-#if !defined (FICL_PLATFORM_EXTEND)
-#define FICL_PLATFORM_EXTEND 1
-#endif
-#endif
-
-#if !defined (FICL_PLATFORM_EXTEND)
-#define FICL_PLATFORM_EXTEND 0
-#endif
-
-
-/*
-** FICL_WANT_FILE
-** Includes the FILE and FILE-EXT wordset and associated code. Turn this off if you do not
-** have a file system!
-** Contributed by Larry Hastings
-*/
-#if !defined (FICL_WANT_FILE)
-#define FICL_WANT_FILE 1
-#endif
-
-/*
-** FICL_WANT_FLOAT
-** Includes a floating point stack for the VM, and words to do float operations.
-** Contributed by Guy Carver
-*/
-#if !defined (FICL_WANT_FLOAT)
-#define FICL_WANT_FLOAT 1
-#endif
-
-/*
-** FICL_WANT_DEBUGGER
-** Inludes a simple source level debugger
-*/
-#if !defined (FICL_WANT_DEBUGGER)
-#define FICL_WANT_DEBUGGER 1
-#endif
-
-/*
-** FICL_EXTENDED_PREFIX enables a bunch of extra prefixes in prefix.c and prefix.fr (if
-** included as part of softcore.c)
-*/
-#if !defined FICL_EXTENDED_PREFIX
-#define FICL_EXTENDED_PREFIX 0
-#endif
-
-/*
-** User variables: per-instance variables bound to the VM.
-** Kinda like thread-local storage. Could be implemented in a
-** VM private dictionary, but I've chosen the lower overhead
-** approach of an array of CELLs instead.
-*/
-#if !defined FICL_WANT_USER
-#define FICL_WANT_USER 1
-#endif
-
-#if !defined FICL_USER_CELLS
-#define FICL_USER_CELLS 16
-#endif
-
-/*
-** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and
-** a private dictionary for local variable compilation.
-*/
-#if !defined FICL_WANT_LOCALS
-#define FICL_WANT_LOCALS 1
-#endif
-
-/* Max number of local variables per definition */
-#if !defined FICL_MAX_LOCALS
-#define FICL_MAX_LOCALS 16
-#endif
-
-/*
-** FICL_WANT_OOP
-** Inludes object oriented programming support (in softwords)
-** OOP support requires locals and user variables!
-*/
-#if !(FICL_WANT_LOCALS) || !(FICL_WANT_USER)
-#if !defined (FICL_WANT_OOP)
-#define FICL_WANT_OOP 0
-#endif
-#endif
-
-#if !defined (FICL_WANT_OOP)
-#define FICL_WANT_OOP 1
-#endif
-
-/*
-** FICL_WANT_SOFTWORDS
-** Controls inclusion of all softwords in softcore.c
-*/
-#if !defined (FICL_WANT_SOFTWORDS)
-#define FICL_WANT_SOFTWORDS 1
-#endif
-
-/*
-** FICL_MULTITHREAD enables dictionary mutual exclusion
-** wia the ficlLockDictionary system dependent function.
-** Note: this implementation is experimental and poorly
-** tested. Further, it's unnecessary unless you really
-** intend to have multiple SESSIONS (poor choice of name
-** on my part) - that is, threads that modify the dictionary
-** at the same time.
-*/
-#if !defined FICL_MULTITHREAD
-#define FICL_MULTITHREAD 0
-#endif
-
-/*
-** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
-** defined in C in sysdep.c. Use this if you cannot easily
-** generate an inline asm definition
-*/
-#if !defined (PORTABLE_LONGMULDIV)
-#define PORTABLE_LONGMULDIV 0
-#endif
-
-/*
-** INLINE_INNER_LOOP causes the inner interpreter to be inline code
-** instead of a function call. This is mainly because MS VC++ 5
-** chokes with an internal compiler error on the function version.
-** in release mode. Sheesh.
-*/
-#if !defined INLINE_INNER_LOOP
-#if defined _DEBUG
-#define INLINE_INNER_LOOP 0
-#else
-#define INLINE_INNER_LOOP 1
-#endif
-#endif
-
-/*
-** FICL_ROBUST enables bounds checking of stacks and the dictionary.
-** This will detect stack over and underflows and dictionary overflows.
-** Any exceptional condition will result in an assertion failure.
-** (As generated by the ANSI assert macro)
-** FICL_ROBUST == 1 --> stack checking in the outer interpreter
-** FICL_ROBUST == 2 also enables checking in many primitives
-*/
-
-#if !defined FICL_ROBUST
-#define FICL_ROBUST 2
-#endif
-
-/*
-** FICL_DEFAULT_STACK Specifies the default size (in CELLs) of
-** a new virtual machine's stacks, unless overridden at
-** create time.
-*/
-#if !defined FICL_DEFAULT_STACK
-#define FICL_DEFAULT_STACK 128
-#endif
-
-/*
-** FICL_DEFAULT_DICT specifies the number of CELLs to allocate
-** for the system dictionary by default. The value
-** can be overridden at startup time as well.
-** FICL_DEFAULT_ENV specifies the number of cells to allot
-** for the environment-query dictionary.
-*/
-#if !defined FICL_DEFAULT_DICT
-#define FICL_DEFAULT_DICT 12288
-#endif
-
-#if !defined FICL_DEFAULT_ENV
-#define FICL_DEFAULT_ENV 512
-#endif
-
-/*
-** FICL_DEFAULT_VOCS specifies the maximum number of wordlists in
-** the dictionary search order. See Forth DPANS sec 16.3.3
-** (file://dpans16.htm#16.3.3)
-*/
-#if !defined FICL_DEFAULT_VOCS
-#define FICL_DEFAULT_VOCS 16
-#endif
-
-/*
-** FICL_MAX_PARSE_STEPS controls the size of an array in the FICL_SYSTEM structure
-** that stores pointers to parser extension functions. I would never expect to have
-** more than 8 of these, so that's the default limit. Too many of these functions
-** will probably exact a nasty performance penalty.
-*/
-#if !defined FICL_MAX_PARSE_STEPS
-#define FICL_MAX_PARSE_STEPS 8
-#endif
-
-/*
-** FICL_ALIGN is the power of two to which the dictionary
-** pointer address must be aligned. This value is usually
-** either 1 or 2, depending on the memory architecture
-** of the target system; 2 is safe on any 16 or 32 bit
-** machine. 3 would be appropriate for a 64 bit machine.
-*/
-#if !defined FICL_ALIGN
-#define FICL_ALIGN 2
-#define FICL_ALIGN_ADD ((1 << FICL_ALIGN) - 1)
-#endif
-
-/*
-** System dependent routines --
-** edit the implementations in sysdep.c to be compatible
-** with your runtime environment...
-** ficlTextOut sends a NULL terminated string to the
-** default output device - used for system error messages
-** ficlMalloc and ficlFree have the same semantics as malloc and free
-** in standard C
-** ficlLongMul multiplies two UNS32s and returns a 64 bit unsigned
-** product
-** ficlLongDiv divides an UNS64 by an UNS32 and returns UNS32 quotient
-** and remainder
-*/
-struct vm;
-void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
-void *ficlMalloc (size_t size);
-void ficlFree (void *p);
-void *ficlRealloc(void *p, size_t size);
-/*
-** Stub function for dictionary access control - does nothing
-** by default, user can redefine to guarantee exclusive dict
-** access to a single thread for updates. All dict update code
-** must be bracketed as follows:
-** ficlLockDictionary(TRUE);
-** <code that updates dictionary>
-** ficlLockDictionary(FALSE);
-**
-** Returns zero if successful, nonzero if unable to acquire lock
-** before timeout (optional - could also block forever)
-**
-** NOTE: this function must be implemented with lock counting
-** semantics: nested calls must behave properly.
-*/
-#if FICL_MULTITHREAD
-int ficlLockDictionary(short fLock);
-#else
-#define ficlLockDictionary(x) 0 /* ignore */
-#endif
-
-/*
-** 64 bit integer math support routines: multiply two UNS32s
-** to get a 64 bit product, & divide the product by an UNS32
-** to get an UNS32 quotient and remainder. Much easier in asm
-** on a 32 bit CPU than in C, which usually doesn't support
-** the double length result (but it should).
-*/
-DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y);
-UNSQR ficlLongDiv(DPUNS q, FICL_UNS y);
-
-
-/*
-** FICL_HAVE_FTRUNCATE indicates whether the current OS supports
-** the ftruncate() function (available on most UNIXes). This
-** function is necessary to provide the complete File-Access wordset.
-*/
-#if !defined (FICL_HAVE_FTRUNCATE)
-#define FICL_HAVE_FTRUNCATE 0
-#endif
-
-
-#endif /*__SYSDEP_H__*/
--- a/testmain.c
+++ /dev/null
@@ -1,367 +1,0 @@
-/*
-** stub main for testing FICL under Win32
-** $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.
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <time.h>
-#if defined (_WIN32)
-#include <direct.h>
-#endif
-#include <sys/types.h>
-#include <sys/stat.h>
-#ifdef linux
-#include <unistd.h>
-#endif
-
-#include "ficl.h"
-
-/*
-** Ficl interface to _getcwd (Win32)
-** Prints the current working directory using the VM's
-** textOut method...
-*/
-static void ficlGetCWD(FICL_VM *pVM)
-{
- char *cp;
-
-#if defined (_WIN32)
- cp = _getcwd(NULL, 80);
-#else
- cp = getcwd(NULL, 80);
-#endif
- vmTextOut(pVM, cp, 1);
- free(cp);
- return;
-}
-
-/*
-** Ficl interface to _chdir (Win32)
-** Gets a newline (or NULL) delimited string from the input
-** and feeds it to the Win32 chdir function...
-** Example:
-** cd c:\tmp
-*/
-static void ficlChDir(FICL_VM *pVM)
-{
- FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
- vmGetString(pVM, pFS, '\n');
- if (pFS->count > 0)
- {
- int err = chdir(pFS->text);
- if (err)
- {
- vmTextOut(pVM, "Error: path not found", 1);
- vmThrow(pVM, VM_QUIT);
- }
- }
- else
- {
- vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
- }
- return;
-}
-
-/*
-** Ficl interface to system (ANSI)
-** Gets a newline (or NULL) delimited string from the input
-** and feeds it to the Win32 system function...
-** Example:
-** system del *.*
-** \ ouch!
-*/
-static void ficlSystem(FICL_VM *pVM)
-{
- FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
-
- vmGetString(pVM, pFS, '\n');
- if (pFS->count > 0)
- {
- int err = system(pFS->text);
- if (err)
- {
- sprintf(pVM->pad, "System call returned %d", err);
- vmTextOut(pVM, pVM->pad, 1);
- vmThrow(pVM, VM_QUIT);
- }
- }
- else
- {
- vmTextOut(pVM, "Warning (system): nothing happened", 1);
- }
- return;
-}
-
-/*
-** Ficl add-in to load a text file and execute it...
-** Cheesy, but illustrative.
-** Line oriented... filename is newline (or NULL) delimited.
-** Example:
-** load test.ficl
-*/
-#define nLINEBUF 256
-static void ficlLoad(FICL_VM *pVM)
-{
- char cp[nLINEBUF];
- char filename[nLINEBUF];
- FICL_STRING *pFilename = (FICL_STRING *)filename;
- int nLine = 0;
- FILE *fp;
- int result;
- CELL id;
- struct stat buf;
-
-
- vmGetString(pVM, pFilename, '\n');
-
- if (pFilename->count <= 0)
- {
- vmTextOut(pVM, "Warning (load): nothing happened", 1);
- return;
- }
-
- /*
- ** get the file's size and make sure it exists
- */
- result = stat( pFilename->text, &buf );
-
- if (result != 0)
- {
- vmTextOut(pVM, "Unable to stat file: ", 0);
- vmTextOut(pVM, pFilename->text, 1);
- vmThrow(pVM, VM_QUIT);
- }
-
- fp = fopen(pFilename->text, "r");
- if (!fp)
- {
- vmTextOut(pVM, "Unable to open file ", 0);
- vmTextOut(pVM, pFilename->text, 1);
- vmThrow(pVM, VM_QUIT);
- }
-
- id = pVM->sourceID;
- pVM->sourceID.p = (void *)fp;
-
- /* feed each line to ficlExec */
- while (fgets(cp, nLINEBUF, fp))
- {
- int len = strlen(cp) - 1;
-
- nLine++;
- if (len <= 0)
- continue;
-
- if (cp[len] == '\n')
- cp[len] = '\0';
-
- result = ficlExec(pVM, cp);
- /* handle "bye" in loaded files. --lch */
- switch (result)
- {
- case VM_OUTOFTEXT:
- case VM_USEREXIT:
- break;
-
- default:
- pVM->sourceID = id;
- fclose(fp);
- vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
- break;
- }
- }
- /*
- ** Pass an empty line with SOURCE-ID == -1 to flush
- ** any pending REFILLs (as required by FILE wordset)
- */
- pVM->sourceID.i = -1;
- ficlExec(pVM, "");
-
- pVM->sourceID = id;
- fclose(fp);
-
- /* handle "bye" in loaded files. --lch */
- if (result == VM_USEREXIT)
- vmThrow(pVM, VM_USEREXIT);
- return;
-}
-
-/*
-** Dump a tab delimited file that summarizes the contents of the
-** dictionary hash table by hashcode...
-*/
-static void spewHash(FICL_VM *pVM)
-{
- FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
- FICL_WORD *pFW;
- FILE *pOut;
- unsigned i;
- unsigned nHash = pHash->size;
-
- if (!vmGetWordToPad(pVM))
- vmThrow(pVM, VM_OUTOFTEXT);
-
- pOut = fopen(pVM->pad, "w");
- if (!pOut)
- {
- vmTextOut(pVM, "unable to open file", 1);
- return;
- }
-
- for (i=0; i < nHash; i++)
- {
- int n = 0;
-
- pFW = pHash->table[i];
- while (pFW)
- {
- n++;
- pFW = pFW->link;
- }
-
- fprintf(pOut, "%d\t%d", i, n);
-
- pFW = pHash->table[i];
- while (pFW)
- {
- fprintf(pOut, "\t%s", pFW->name);
- pFW = pFW->link;
- }
-
- fprintf(pOut, "\n");
- }
-
- fclose(pOut);
- return;
-}
-
-static void ficlBreak(FICL_VM *pVM)
-{
- pVM->state = pVM->state;
- return;
-}
-
-static void ficlClock(FICL_VM *pVM)
-{
- clock_t now = clock();
- stackPushUNS(pVM->pStack, (FICL_UNS)now);
- return;
-}
-
-static void clocksPerSec(FICL_VM *pVM)
-{
- stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
- return;
-}
-
-
-void buildTestInterface(FICL_SYSTEM *pSys)
-{
- ficlBuild(pSys, "break", ficlBreak, FW_DEFAULT);
- ficlBuild(pSys, "clock", ficlClock, FW_DEFAULT);
- ficlBuild(pSys, "cd", ficlChDir, FW_DEFAULT);
- ficlBuild(pSys, "load", ficlLoad, FW_DEFAULT);
- ficlBuild(pSys, "pwd", ficlGetCWD, FW_DEFAULT);
- ficlBuild(pSys, "system", ficlSystem, FW_DEFAULT);
- ficlBuild(pSys, "spewhash", spewHash, FW_DEFAULT);
- ficlBuild(pSys, "clocks/sec",
- clocksPerSec, FW_DEFAULT);
-
- return;
-}
-
-
-#if !defined (_WINDOWS)
-#define nINBUF 256
-
-#if !defined (_WIN32)
-#define __try
-#define __except(i) if (0)
-#endif
-
-int main(int argc, char **argv)
-{
- int ret = 0;
- char in[nINBUF];
- FICL_VM *pVM;
- FICL_SYSTEM *pSys;
-
- pSys = ficlInitSystem(10000);
- buildTestInterface(pSys);
- pVM = ficlNewVM(pSys);
-
- ret = ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
-
- /*
- ** load file from cmd line...
- */
- if (argc > 1)
- {
- sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
- __try
- {
- ret = ficlEvaluate(pVM, in);
- }
- __except(1)
- {
- vmTextOut(pVM, "exception -- cleaning up", 1);
- vmReset(pVM);
- }
- }
-
- while (ret != VM_USEREXIT)
- {
- fgets(in, nINBUF, stdin);
- __try
- {
- ret = ficlExec(pVM, in);
- }
- __except(1)
- {
- vmTextOut(pVM, "exception -- cleaning up", 1);
- vmReset(pVM);
- }
- }
-
- ficlTermSystem(pSys);
- return 0;
-}
-
-#endif
-
--- a/tools.c
+++ b/tools.c
@@ -1,886 +1,926 @@
-/*******************************************************************
-** 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
-*/
-
-#include <stdlib.h>
-#include <stdio.h> /* sprintf */
-#include <string.h>
-#include <ctype.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 ", 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, c.u);
- }
- else
- sprintf(cp, "literal %ld (%#lx)", c.i, c.u);
- break;
- case STRINGLIT:
- {
- FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
- pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
- sprintf(cp, "s\" %.*s\"", sp->count, sp->text);
- }
- break;
- case CSTRINGLIT:
- {
- FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
- pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
- sprintf(cp, "c\" %.*s\"", sp->count, sp->text);
- }
- break;
- case IF:
- c = *++pc;
- if (c.i > 0)
- sprintf(cp, "if / while (branch %d)", pc+c.i-param0);
- else
- sprintf(cp, "until (branch %d)", pc+c.i-param0);
- break;
- case BRANCH:
- c = *++pc;
- if (c.i > 0)
- sprintf(cp, "else (branch %d)", pc+c.i-param0);
- else
- sprintf(cp, "repeat (branch %d)", pc+c.i-param0);
- break;
-
- case QDO:
- c = *++pc;
- sprintf(cp, "?do (leave %d)", (CELL *)c.p-param0);
- break;
- case DO:
- c = *++pc;
- sprintf(cp, "do (leave %d)", (CELL *)c.p-param0);
- break;
- case LOOP:
- c = *++pc;
- sprintf(cp, "loop (branch %d)", pc+c.i-param0);
- break;
- case PLOOP:
- c = *++pc;
- sprintf(cp, "+loop (branch %d)", pc+c.i-param0);
- break;
- default:
- sprintf(cp, "%.*s", pFW->nName, pFW->name);
- break;
- }
-
- }
- else /* probably not a word - punt and print value */
- {
- sprintf(cp, "%ld ( %#lx )", pc->i, 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)", pFW->param->i, pFW->param->u);
- vmTextOut(pVM, pVM->pad, 1);
- break;
-
-#if FICL_WANT_USER
- case USER:
- sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
- vmTextOut(pVM, pVM->pad, 1);
- break;
-#endif
-
- case CONSTANT:
- sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
- 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;
- 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;
- vmTextOut(pVM, pPad, 1);
- }
- else
- {
- len = nCOLWIDTH - nChars % nCOLWIDTH;
- while (len-- > 0)
- pPad[nChars++] = ' ';
- }
-
- if (nChars > 70)
- {
- pPad[nChars] = '\0';
- nChars = 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;
-}
-
+/*******************************************************************
+** 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.12 2010/08/12 13:57:22 asau Exp $
+*******************************************************************/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+/*
+** 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.
+** fiColonParen fiDoDoes createParen fiVariableParen fiUserParen fiConstantParen
+**
+** Step and break debugger for Ficl
+** debug ( xt -- ) Start debugging an xt
+** Set a breakpoint
+** Specify breakpoint default action
+*/
+
+#include <stdlib.h>
+#include <stdio.h> /* sprintf */
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+
+
+static void ficlPrimitiveStepIn(ficlVm *vm);
+static void ficlPrimitiveStepOver(ficlVm *vm);
+static void ficlPrimitiveStepBreak(ficlVm *vm);
+
+
+
+void ficlCallbackAssert(ficlCallback *callback, int expression, char *expressionString, char *filename, int line)
+#if FICL_ROBUST >= 1
+{+ if (!expression)
+ {+ static char buffer[256];
+ sprintf(buffer, "ASSERTION FAILED at %s:%d: \"%s\"\n", filename, line, expressionString);
+ ficlCallbackTextOut(callback, buffer);
+ exit(-1);
+ }
+}
+#else /* FICL_ROBUST >= 1 */
+{+ FICL_IGNORE(callback);
+ FICL_IGNORE(expression);
+ FICL_IGNORE(expressionString);
+ FICL_IGNORE(filename);
+ FICL_IGNORE(line);
+}
+#endif /* FICL_ROBUST >= 1 */
+
+
+
+/**************************************************************************
+ 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 ficlVmSetBreak(ficlVm *vm, ficlBreakpoint *pBP)
+{+ ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
+ FICL_VM_ASSERT(vm, pStep);
+
+ pBP->address = vm->ip;
+ pBP->oldXT = *vm->ip;
+ *vm->ip = pStep;
+}
+
+
+/**************************************************************************
+** d e b u g P r o m p t
+**************************************************************************/
+static void ficlDebugPrompt(ficlVm *vm)
+{+ ficlVmTextOut(vm, "dbg> ");
+}
+
+
+#if 0
+static int isPrimitive(ficlWord *word)
+{+ ficlWordKind wk = ficlWordClassify(word);
+ return ((wk != COLON) && (wk != DOES));
+}
+#endif
+
+
+/**************************************************************************
+ 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 ficlPrimitiveHashSummary(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *pFHash;
+ ficlWord **hash;
+ unsigned size;
+ ficlWord *word;
+ unsigned i;
+ int nMax = 0;
+ int nWords = 0;
+ int nFilled;
+ double avg = 0.0;
+ double best;
+ int nAvg, nRem, nDepth;
+
+ FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
+
+ pFHash = dictionary->wordlists[dictionary->wordlistCount - 1];
+ hash = pFHash->table;
+ size = pFHash->size;
+ nFilled = size;
+
+ for (i = 0; i < size; i++)
+ {+ int n = 0;
+ word = hash[i];
+
+ while (word)
+ {+ ++n;
+ ++nWords;
+ word = word->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(vm->pad,
+ "%d bins, %2.0f%% filled, Depth: Max=%d, Avg=%2.1f, Best=%2.1f, Score: %2.0f%%\n",
+ size,
+ (double)nFilled * 100.0 / size, nMax,
+ avg,
+ best,
+ 100.0 * best / avg);
+
+ ficlVmTextOut(vm, vm->pad);
+
+ return;
+}
+#endif
+
+/*
+** Here's the outer part of the decompiler. It's
+** 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 ficlPrimitiveSeeXT(ficlVm *vm)
+{+ ficlWord *word;
+ ficlWordKind kind;
+
+ word = (ficlWord *)ficlStackPopPointer(vm->dataStack);
+ kind = ficlWordClassify(word);
+
+ switch (kind)
+ {+ case FICL_WORDKIND_COLON:
+ sprintf(vm->pad, ": %.*s\n", word->length, word->name);
+ ficlVmTextOut(vm, vm->pad);
+ ficlDictionarySee(ficlVmGetDictionary(vm), word, &(vm->callback));
+ break;
+
+ case FICL_WORDKIND_DOES:
+ ficlVmTextOut(vm, "does>\n");
+ ficlDictionarySee(ficlVmGetDictionary(vm), (ficlWord *)word->param->p, &(vm->callback));
+ break;
+
+ case FICL_WORDKIND_CREATE:
+ ficlVmTextOut(vm, "create\n");
+ break;
+
+ case FICL_WORDKIND_VARIABLE:
+ sprintf(vm->pad, "variable = %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+
+#if FICL_WANT_USER
+ case FICL_WORDKIND_USER:
+ sprintf(vm->pad, "user variable %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+#endif
+
+ case FICL_WORDKIND_CONSTANT:
+ sprintf(vm->pad, "constant = %ld (%#lx)\n", word->param->i, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+
+ case FICL_WORDKIND_2CONSTANT:
+ sprintf(vm->pad, "constant = %ld %ld (%#lx %#lx)\n", word->param[1].i, word->param->i, word->param[1].u, word->param->u);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+
+ default:
+ sprintf(vm->pad, "%.*s is a primitive\n", word->length, word->name);
+ ficlVmTextOut(vm, vm->pad);
+ break;
+ }
+
+ if (word->flags & FICL_WORD_IMMEDIATE)
+ {+ ficlVmTextOut(vm, "immediate\n");
+ }
+
+ if (word->flags & FICL_WORD_COMPILE_ONLY)
+ {+ ficlVmTextOut(vm, "compile-only\n");
+ }
+
+ return;
+}
+
+
+static void ficlPrimitiveSee(ficlVm *vm)
+{+ ficlPrimitiveTick(vm);
+ ficlPrimitiveSeeXT(vm);
+ 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"
+**************************************************************************/
+static void ficlPrimitiveDebugXT(ficlVm *vm)
+{+ ficlWord *xt = ficlStackPopPointer(vm->dataStack);
+ ficlWordKind wk = ficlWordClassify(xt);
+
+ ficlStackPushPointer(vm->dataStack, xt);
+ ficlPrimitiveSeeXT(vm);
+
+ switch (wk)
+ {+ case FICL_WORDKIND_COLON:
+ case FICL_WORDKIND_DOES:
+ /*
+ ** Run the colon code and set a breakpoint at the next instruction
+ */
+ ficlVmExecuteWord(vm, xt);
+ ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
+ break;
+
+ default:
+ ficlVmExecuteWord(vm, 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.
+**************************************************************************/
+static void ficlPrimitiveStepIn(ficlVm *vm)
+{+ /*
+ ** Do one step of the inner loop
+ */
+ ficlVmExecuteWord(vm, *vm->ip++);
+
+ /*
+ ** Now set a breakpoint at the next instruction
+ */
+ ficlVmSetBreak(vm, &(vm->callback.system->breakpoint));
+
+ 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
+**************************************************************************/
+static void ficlPrimitiveStepOver(ficlVm *vm)
+{+ ficlWord *word;
+ ficlWordKind kind;
+ ficlWord *pStep = ficlSystemLookup(vm->callback.system, "step-break");
+ FICL_VM_ASSERT(vm, pStep);
+
+ word = *vm->ip;
+ kind = ficlWordClassify(word);
+
+ switch (kind)
+ {+ case FICL_WORDKIND_COLON:
+ case FICL_WORDKIND_DOES:
+ /*
+ ** assume that the next ficlCell holds an instruction
+ ** set a breakpoint there and return to the inner interpreter
+ */
+ vm->callback.system->breakpoint.address = vm->ip + 1;
+ vm->callback.system->breakpoint.oldXT = vm->ip[1];
+ vm->ip[1] = pStep;
+ break;
+
+ default:
+ ficlPrimitiveStepIn(vm);
+ break;
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ s t e p - b r e a k
+** Ficl
+** Handles breakpoints for stepped execution.
+** Upon entry, breakpoint 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)
+**************************************************************************/
+
+extern char *ficlDictionaryInstructionNames[];
+
+static void ficlPrimitiveStepBreak(ficlVm *vm)
+{+ ficlString command;
+ ficlWord *word;
+ ficlWord *pOnStep;
+ ficlWordKind kind;
+
+ if (!vm->restart)
+ {+ FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.address);
+ FICL_VM_ASSERT(vm, vm->callback.system->breakpoint.oldXT);
+ /*
+ ** Clear the breakpoint that caused me to run
+ ** Restore the original instruction at the breakpoint,
+ ** and restore the IP
+ */
+ vm->ip = (ficlIp)(vm->callback.system->breakpoint.address);
+ *vm->ip = vm->callback.system->breakpoint.oldXT;
+
+ /*
+ ** If there's an onStep, do it
+ */
+ pOnStep = ficlSystemLookup(vm->callback.system, "on-step");
+ if (pOnStep)
+ ficlVmExecuteXT(vm, pOnStep);
+
+ /*
+ ** Print the name of the next instruction
+ */
+ word = vm->callback.system->breakpoint.oldXT;
+
+ kind = ficlWordClassify(word);
+
+ switch (kind)
+ {+ case FICL_WORDKIND_INSTRUCTION:
+ case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
+ sprintf(vm->pad, "next: %s (instruction %ld)\n", ficlDictionaryInstructionNames[(long)word], (long)word);
+ break;
+ default:
+ sprintf(vm->pad, "next: %s\n", word->name);
+ break;
+ }
+
+ ficlVmTextOut(vm, vm->pad);
+ ficlDebugPrompt(vm);
+ }
+ else
+ {+ vm->restart = 0;
+ }
+
+ command = ficlVmGetWord(vm);
+
+ switch (command.text[0])
+ {+ case 'i':
+ ficlPrimitiveStepIn(vm);
+ break;
+
+ case 'o':
+ ficlPrimitiveStepOver(vm);
+ break;
+
+ case 'g':
+ break;
+
+ case 'l':
+ {+ ficlWord *xt;
+ xt = ficlDictionaryFindEnclosingWord(ficlVmGetDictionary(vm), (ficlCell *)(vm->ip));
+ if (xt)
+ {+ ficlStackPushPointer(vm->dataStack, xt);
+ ficlPrimitiveSeeXT(vm);
+ }
+ else
+ {+ ficlVmTextOut(vm, "sorry - can't do that\n");
+ }
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+ break;
+ }
+
+ case 'q':
+ {+ ficlVmTextOut(vm, FICL_PROMPT);
+ ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
+ break;
+ }
+
+ case 'x':
+ {+ /*
+ ** Take whatever's left in the TIB and feed it to a subordinate ficlVmExecuteString
+ */
+ int returnValue;
+ ficlString s;
+ ficlWord *oldRunningWord = vm->runningWord;
+
+ FICL_STRING_SET_POINTER(s, vm->tib.text + vm->tib.index);
+ FICL_STRING_SET_LENGTH(s, vm->tib.end - FICL_STRING_GET_POINTER(s));
+
+ returnValue = ficlVmExecuteString(vm, s);
+
+ if (returnValue == FICL_VM_STATUS_OUT_OF_TEXT)
+ {+ returnValue = FICL_VM_STATUS_RESTART;
+ vm->runningWord = oldRunningWord;
+ ficlVmTextOut(vm, "\n");
+ }
+
+ ficlVmThrow(vm, returnValue);
+ break;
+ }
+
+ default:
+ {+ ficlVmTextOut(vm,
+ "i -- step In\n"
+ "o -- step Over\n"
+ "g -- Go (execute to completion)\n"
+ "l -- List source code\n"
+ "q -- Quit (stop debugging and abort)\n"
+ "x -- eXecute the rest of the line as Ficl words\n"
+ );
+ ficlDebugPrompt(vm);
+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+ break;
+ }
+ }
+
+ return;
+}
+
+
+/**************************************************************************
+ 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 ficlPrimitiveBye(ficlVm *vm)
+{+ ficlVmThrow(vm, FICL_VM_STATUS_USER_EXIT);
+ return;
+}
+
+
+/**************************************************************************
+ d i s p l a y S t a c k
+** TOOLS
+** Display the parameter stack (code for ".s")
+**************************************************************************/
+
+struct stackContext
+{+ ficlVm *vm;
+ ficlDictionary *dictionary;
+ int count;
+};
+
+static ficlInteger ficlStackDisplayCallback(void *c, ficlCell *cell)
+{+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[64];
+ sprintf(buffer, "[0x%08x %3d]: %12d (0x%08x)\n", cell, context->count++, cell->i, cell->i);
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+void ficlStackDisplay(ficlStack *stack, ficlStackWalkFunction callback, void *context)
+{+ ficlVm *vm = stack->vm;
+ char buffer[128];
+ struct stackContext myContext;
+
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ sprintf(buffer, "[%s stack has %d entries, top at 0x%08x]\n", stack->name, ficlStackDepth(stack), stack->top);
+ ficlVmTextOut(vm, buffer);
+
+ if (callback == NULL)
+ {+ myContext.vm = vm;
+ myContext.count = 0;
+ context = &myContext;
+ callback = ficlStackDisplayCallback;
+ }
+ ficlStackWalk(stack, callback, context, FICL_FALSE);
+
+ sprintf(buffer, "[%s stack base at 0x%08x]\n", stack->name, stack->base);
+ ficlVmTextOut(vm, buffer);
+
+ return;
+}
+
+
+void ficlVmDisplayDataStack(ficlVm *vm)
+{+ ficlStackDisplay(vm->dataStack, NULL, NULL);
+ return;
+}
+
+
+
+
+static ficlInteger ficlStackDisplaySimpleCallback(void *c, ficlCell *cell)
+{+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[32];
+ sprintf(buffer, "%s%d", context->count ? " " : "", cell->i);
+ context->count++;
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+
+void ficlVmDisplayDataStackSimple(ficlVm *vm)
+{+ ficlStack *stack = vm->dataStack;
+ char buffer[32];
+ struct stackContext context;
+
+ FICL_STACK_CHECK(stack, 0, 0);
+
+ sprintf(buffer, "[%d] ", ficlStackDepth(stack));
+ ficlVmTextOut(vm, buffer);
+
+ context.vm = vm;
+ context.count = 0;
+ ficlStackWalk(stack, ficlStackDisplaySimpleCallback, &context, FICL_TRUE);
+ return;
+}
+
+
+
+
+static ficlInteger ficlReturnStackDisplayCallback(void *c, ficlCell *cell)
+{+ struct stackContext *context = (struct stackContext *)c;
+ char buffer[128];
+
+ sprintf(buffer, "[0x%08x %3d] %12d (0x%08x)", cell, context->count++, cell->i, cell->i);
+
+ /*
+ ** Attempt to find the word that contains the return
+ ** stack address (as if it is part of a colon definition).
+ ** If this works, also print the name of the word.
+ */
+ if (ficlDictionaryIncludes(context->dictionary, cell->p))
+ {+ ficlWord *word = ficlDictionaryFindEnclosingWord(context->dictionary, cell->p);
+ if (word)
+ {+ int offset = (ficlCell *)cell->p - &word->param[0];
+ sprintf(buffer + strlen(buffer), ", %s + %d ", word->name, offset);
+ }
+ }
+ strcat(buffer, "\n");
+ ficlVmTextOut(context->vm, buffer);
+ return FICL_TRUE;
+}
+
+
+void ficlVmDisplayReturnStack(ficlVm *vm)
+{+ struct stackContext context;
+ context.vm = vm;
+ context.count = 0;
+ context.dictionary = ficlVmGetDictionary(vm);
+ ficlStackDisplay(vm->returnStack, ficlReturnStackDisplayCallback, &context);
+ return;
+}
+
+
+
+
+/**************************************************************************
+ f o r g e t - w i d
+**
+**************************************************************************/
+static void ficlPrimitiveForgetWid(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash;
+
+ hash = (ficlHash *)ficlStackPopPointer(vm->dataStack);
+ ficlHashForget(hash, dictionary->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 ficlPrimitiveForget(ficlVm *vm)
+{+ void *where;
+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash = dictionary->compilationWordlist;
+
+ ficlPrimitiveTick(vm);
+ where = ((ficlWord *)ficlStackPopPointer(vm->dataStack))->name;
+ ficlHashForget(hash, where);
+ dictionary->here = FICL_POINTER_TO_CELL(where);
+
+ return;
+}
+
+
+/**************************************************************************
+ w o r d s
+**
+**************************************************************************/
+#define nCOLWIDTH 8
+static void ficlPrimitiveWords(ficlVm *vm)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlHash *hash = dictionary->wordlists[dictionary->wordlistCount - 1];
+ ficlWord *wp;
+ int nChars = 0;
+ int len;
+ unsigned i;
+ int nWords = 0;
+ char *cp;
+ char *pPad = vm->pad;
+
+ for (i = 0; i < hash->size; i++)
+ {+ for (wp = hash->table[i]; wp != NULL; wp = wp->link, nWords++)
+ {+ if (wp->length == 0) /* ignore :noname defs */
+ continue;
+
+ cp = wp->name;
+ nChars += sprintf(pPad + nChars, "%s", cp);
+
+ if (nChars > 70)
+ {+ pPad[nChars++] = '\n';
+ pPad[nChars] = '\0';
+ nChars = 0;
+ ficlVmTextOut(vm, pPad);
+ }
+ else
+ {+ len = nCOLWIDTH - nChars % nCOLWIDTH;
+ while (len-- > 0)
+ pPad[nChars++] = ' ';
+ }
+
+ if (nChars > 70)
+ {+ pPad[nChars++] = '\n';
+ pPad[nChars] = '\0';
+ nChars = 0;
+ ficlVmTextOut(vm, pPad);
+ }
+ }
+ }
+
+ if (nChars > 0)
+ {+ pPad[nChars++] = '\n';
+ pPad[nChars] = '\0';
+ nChars = 0;
+ ficlVmTextOut(vm, pPad);
+ }
+
+ sprintf(vm->pad, "Dictionary: %d words, %ld cells used of %u total\n",
+ nWords, (long) (dictionary->here - dictionary->base), dictionary->size);
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+
+/**************************************************************************
+ l i s t E n v
+** Print symbols defined in the environment
+**************************************************************************/
+static void ficlPrimitiveListEnv(ficlVm *vm)
+{+ ficlDictionary *dictionary = vm->callback.system->environment;
+ ficlHash *hash = dictionary->forthWordlist;
+ ficlWord *word;
+ unsigned i;
+ int counter = 0;
+
+ for (i = 0; i < hash->size; i++)
+ {+ for (word = hash->table[i]; word != NULL; word = word->link, counter++)
+ {+ ficlVmTextOut(vm, word->name);
+ ficlVmTextOut(vm, "\n");
+ }
+ }
+
+ sprintf(vm->pad, "Environment: %d words, %ld cells used of %u total\n",
+ counter, (long) (dictionary->here - dictionary->base), dictionary->size);
+ ficlVmTextOut(vm, vm->pad);
+ return;
+}
+
+
+
+
+/*
+** This word lists the parse steps in order
+*/
+void ficlPrimitiveParseStepList(ficlVm *vm)
+{+ int i;
+ ficlSystem *system = vm->callback.system;
+ FICL_VM_ASSERT(vm, system);
+
+ ficlVmTextOut(vm, "Parse steps:\n");
+ ficlVmTextOut(vm, "lookup\n");
+
+ for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
+ {+ if (system->parseList[i] != NULL)
+ {+ ficlVmTextOut(vm, system->parseList[i]->name);
+ ficlVmTextOut(vm, "\n");
+ }
+ else break;
+ }
+ return;
+}
+
+
+/**************************************************************************
+ e n v C o n s t a n t
+** Ficl interface to ficlSystemSetEnvironment and ficlSetEnvD - allow Ficl code to set
+** environment constants...
+**************************************************************************/
+static void ficlPrimitiveEnvConstant(ficlVm *vm)
+{+ unsigned value;
+ FICL_STACK_CHECK(vm->dataStack, 1, 0);
+
+ ficlVmGetWordToPad(vm);
+ value = ficlStackPopUnsigned(vm->dataStack);
+ ficlDictionarySetConstant(ficlSystemGetEnvironment(vm->callback.system), vm->pad, (ficlUnsigned)value);
+ return;
+}
+
+static void ficlPrimitiveEnv2Constant(ficlVm *vm)
+{+ ficl2Integer value;
+
+ FICL_STACK_CHECK(vm->dataStack, 2, 0);
+
+ ficlVmGetWordToPad(vm);
+ value = ficlStackPop2Integer(vm->dataStack);
+ ficlDictionarySet2Constant(ficlSystemGetEnvironment(vm->callback.system), vm->pad, value);
+ 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 ficlSystemCompileTools(ficlSystem *system)
+{+ ficlDictionary *dictionary = ficlSystemGetDictionary(system);
+ ficlDictionary *environment = ficlSystemGetEnvironment(system);
+
+ FICL_SYSTEM_ASSERT(system, dictionary);
+ FICL_SYSTEM_ASSERT(system, environment);
+
+
+ /*
+ ** TOOLS and TOOLS EXT
+ */
+ ficlDictionarySetPrimitive(dictionary, ".s", ficlVmDisplayDataStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".s-simple", ficlVmDisplayDataStackSimple, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "bye", ficlPrimitiveBye, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forget", ficlPrimitiveForget, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "see", ficlPrimitiveSee, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "words", ficlPrimitiveWords, FICL_WORD_DEFAULT);
+
+ /*
+ ** Set TOOLS environment query values
+ */
+ ficlDictionarySetConstant(environment, "tools", FICL_TRUE);
+ ficlDictionarySetConstant(environment, "tools-ext", FICL_FALSE);
+
+ /*
+ ** Ficl extras
+ */
+ ficlDictionarySetPrimitive(dictionary, "r.s", ficlVmDisplayReturnStack, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, ".env", ficlPrimitiveListEnv, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "env-constant",
+ ficlPrimitiveEnvConstant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "env-2constant",
+ ficlPrimitiveEnv2Constant, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "debug-xt", ficlPrimitiveDebugXT, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "parse-order", ficlPrimitiveParseStepList, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "step-break",ficlPrimitiveStepBreak, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "forget-wid",ficlPrimitiveForgetWid, FICL_WORD_DEFAULT);
+ ficlDictionarySetPrimitive(dictionary, "see-xt", ficlPrimitiveSeeXT, FICL_WORD_DEFAULT);
+
+#if FICL_WANT_FLOAT
+ ficlDictionarySetPrimitive(dictionary, ".hash", ficlPrimitiveHashSummary,FICL_WORD_DEFAULT);
+#endif
+
+ return;
+}
+
--- a/unix.c
+++ /dev/null
@@ -1,21 +1,0 @@
-#include <string.h>
-#include <netinet/in.h>
-
-#include "ficl.h"
-
-
-
-unsigned long ficlNtohl(unsigned long number)
-{
- return ntohl(number);
-}
-
-
-
-
-void ficlCompilePlatform(FICL_DICT *dp)
-{
- return;
-}
-
-
--- a/vm.c
+++ b/vm.c
@@ -1,785 +1,3088 @@
-/*******************************************************************
-** 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.
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <string.h>
-#include <ctype.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;
-
- pSrc = skipSpace(pSrc, pEnd);
- SI_SETPTR(si, pSrc);
-
- for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
- {
- count++;
- }
-
- 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;
-}
-
-
+/*******************************************************************
+** 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.14 2010/08/12 13:57:22 asau 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 interpreter.
+*/
+/*
+** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
+** All rights reserved.
+**
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** I am interested in hearing from anyone who uses Ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the Ficl release, please
+** contact me by email at the address above.
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Redistribution and use in source and binary forms, with or without
+** modification, are permitted provided that the following conditions
+** are met:
+** 1. Redistributions of source code must retain the above copyright
+** notice, this list of conditions and the following disclaimer.
+** 2. Redistributions in binary form must reproduce the above copyright
+** notice, this list of conditions and the following disclaimer in the
+** documentation and/or other materials provided with the distribution.
+**
+** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+** SUCH DAMAGE.
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+
+#if FICL_ROBUST >= 2
+#define FICL_VM_CHECK(vm) FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord)
+#else
+#define FICL_VM_CHECK(vm)
+#endif
+
+/**************************************************************************
+ v m B r a n c h R e l a t i v e
+**
+**************************************************************************/
+void ficlVmBranchRelative(ficlVm *vm, int offset)
+{+ vm->ip += offset;
+ return;
+}
+
+
+/**************************************************************************
+ v m C r e a t e
+** Creates a virtual machine either from scratch (if vm is NULL on entry)
+** or by resizing and reinitializing an existing VM to the specified stack
+** sizes.
+**************************************************************************/
+ficlVm *ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack)
+{+ if (vm == NULL)
+ {+ vm = (ficlVm *)ficlMalloc(sizeof (ficlVm));
+ FICL_ASSERT(NULL, vm);
+ memset(vm, 0, sizeof (ficlVm));
+ }
+
+ if (vm->dataStack)
+ ficlStackDestroy(vm->dataStack);
+ vm->dataStack = ficlStackCreate(vm, "data", nPStack);
+
+ if (vm->returnStack)
+ ficlStackDestroy(vm->returnStack);
+ vm->returnStack = ficlStackCreate(vm, "return", nRStack);
+
+#if FICL_WANT_FLOAT
+ if (vm->floatStack)
+ ficlStackDestroy(vm->floatStack);
+ vm->floatStack = ficlStackCreate(vm, "float", nPStack);
+#endif
+
+ ficlVmReset(vm);
+ return vm;
+}
+
+
+/**************************************************************************
+ v m D e l e t e
+** Free all memory allocated to the specified VM and its subordinate
+** structures.
+**************************************************************************/
+void ficlVmDestroy(ficlVm *vm)
+{+ if (vm)
+ {+ ficlFree(vm->dataStack);
+ ficlFree(vm->returnStack);
+#if FICL_WANT_FLOAT
+ ficlFree(vm->floatStack);
+#endif
+ ficlFree(vm);
+ }
+
+ return;
+}
+
+
+
+
+/**************************************************************************
+ v m E x e c u t e
+** Sets up the specified word to be run by the inner interpreter.
+** Executes the word's code part immediately, but in the case of
+** colon definition, the definition itself needs the inner interpreter
+** to complete. This does not happen until control reaches ficlExec
+**************************************************************************/
+void ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
+{+ ficlVmInnerLoop(vm, pWord);
+ return;
+}
+
+
+
+static void ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip)
+ {+ ficlIp destination;
+ switch ((ficlInstruction)(*ip))
+ {+ case ficlInstructionBranchParenWithCheck:
+ *ip = (ficlWord *)ficlInstructionBranchParen;
+ goto RUNTIME_FIXUP;
+
+ case ficlInstructionBranch0ParenWithCheck:
+ *ip = (ficlWord *)ficlInstructionBranch0Paren;
+RUNTIME_FIXUP:
+ ip++;
+ destination = ip + *(int *)ip;
+ switch ((ficlInstruction)*destination)
+ {+ case ficlInstructionBranchParenWithCheck:
+ /* preoptimize where we're jumping to */
+ ficlVmOptimizeJumpToJump(vm, destination);
+ case ficlInstructionBranchParen:
+ {+ destination++;
+ destination += *(int *)destination;
+ *ip = (ficlWord *)(destination - ip);
+ break;
+ }
+ }
+ }
+ }
+
+/**************************************************************************
+ v m I n n e r L o o p
+** the mysterious inner interpreter...
+** 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()
+**************************************************************************/
+
+
+#if FICL_ROBUST <= 1
+ /* turn off stack checking for primitives */
+ #define _CHECK_STACK(stack, top, pop, push)
+#else
+
+#define _CHECK_STACK(stack, top, pop, push) \
+ ficlStackCheckNospill(stack, top, pop, push)
+
+FICL_PLATFORM_INLINE void ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells, int pushCells)
+{+ /*
+ ** Why save and restore stack->top?
+ ** So the simple act of stack checking doesn't force a "register" spill,
+ ** which might mask bugs (places where we needed to spill but didn't).
+ ** --lch
+ */
+ ficlCell *oldTop = stack->top;
+ stack->top = top;
+ ficlStackCheck(stack, popCells, pushCells);
+ stack->top = oldTop;
+}
+
+#endif /* FICL_ROBUST <= 1 */
+
+#define CHECK_STACK(pop, push) _CHECK_STACK(vm->dataStack, dataTop, pop, push)
+#define CHECK_FLOAT_STACK(pop, push) _CHECK_STACK(vm->floatStack, floatTop, pop, push)
+#define CHECK_RETURN_STACK(pop, push) _CHECK_STACK(vm->returnStack, returnTop, pop, push)
+
+
+#if FICL_WANT_FLOAT
+ #define FLOAT_LOCAL_VARIABLE_SPILL \
+ vm->floatStack->top = floatTop;
+ #define FLOAT_LOCAL_VARIABLE_REFILL \
+ floatTop = vm->floatStack->top;
+#else
+ #define FLOAT_LOCAL_VARIABLE_SPILL
+ #define FLOAT_LOCAL_VARIABLE_REFILL
+#endif /* FICL_WANT_FLOAT */
+
+
+#if FICL_WANT_LOCALS
+ #define LOCALS_LOCAL_VARIABLE_SPILL \
+ vm->returnStack->frame = frame;
+ #define LOCALS_LOCAL_VARIABLE_REFILL \
+ frame = vm->returnStack->frame;
+#else
+ #define LOCALS_LOCAL_VARIABLE_SPILL
+ #define LOCALS_LOCAL_VARIABLE_REFILL
+#endif /* FICL_WANT_FLOAT */
+
+
+#define LOCAL_VARIABLE_SPILL \
+ vm->ip = (ficlIp)ip; \
+ vm->dataStack->top = dataTop; \
+ vm->returnStack->top = returnTop; \
+ FLOAT_LOCAL_VARIABLE_SPILL \
+ LOCALS_LOCAL_VARIABLE_SPILL
+
+#define LOCAL_VARIABLE_REFILL \
+ ip = (ficlInstruction *)vm->ip; \
+ dataTop = vm->dataStack->top; \
+ returnTop = vm->returnStack->top; \
+ FLOAT_LOCAL_VARIABLE_REFILL \
+ LOCALS_LOCAL_VARIABLE_REFILL
+
+
+void ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
+{+ register ficlInstruction *ip;
+ register ficlCell *dataTop;
+ register ficlCell *returnTop;
+#if FICL_WANT_FLOAT
+ register ficlCell *floatTop;
+ ficlFloat f;
+#endif /* FICL_WANT_FLOAT */
+#if FICL_WANT_LOCALS
+ register ficlCell *frame;
+#endif /* FICL_WANT_LOCALS */
+ jmp_buf *oldExceptionHandler;
+ jmp_buf exceptionHandler;
+ int except;
+ int once;
+ int count;
+ ficlInstruction instruction;
+ ficlInteger i;
+ ficlUnsigned u;
+ ficlCell c;
+ ficlCountedString *s;
+ ficlCell *cell;
+ char *cp;
+
+ once = (fw != NULL);
+ if (once)
+ count = 1;
+
+ LOCAL_VARIABLE_REFILL;
+
+ oldExceptionHandler = vm->exceptionHandler;
+ vm->exceptionHandler = &exceptionHandler; /* This has to come before the setjmp! */
+ except = setjmp(exceptionHandler);
+
+ if (except)
+ {+ LOCAL_VARIABLE_SPILL;
+ vm->exceptionHandler = oldExceptionHandler;
+ ficlVmThrow(vm, except);
+ }
+
+ for (;;)
+ {+
+ if (once)
+ {+ if (!count--)
+ break;
+ instruction = (ficlInstruction)((void *)fw);
+ }
+ else
+ {+ instruction = *ip++;
+ fw = (ficlWord *)instruction;
+ }
+
+AGAIN:
+ switch (instruction)
+ {+ case ficlInstructionInvalid:
+ {+ ficlVmThrowError(vm, "Error: NULL instruction executed!");
+ return;
+ }
+
+ case ficlInstruction1:
+ case ficlInstruction2:
+ case ficlInstruction3:
+ case ficlInstruction4:
+ case ficlInstruction5:
+ case ficlInstruction6:
+ case ficlInstruction7:
+ case ficlInstruction8:
+ case ficlInstruction9:
+ case ficlInstruction10:
+ case ficlInstruction11:
+ case ficlInstruction12:
+ case ficlInstruction13:
+ case ficlInstruction14:
+ case ficlInstruction15:
+ case ficlInstruction16:
+ {+ CHECK_STACK(0, 1);
+ (++dataTop)->i = instruction;
+ continue;
+ }
+
+ case ficlInstruction0:
+ case ficlInstructionNeg1:
+ case ficlInstructionNeg2:
+ case ficlInstructionNeg3:
+ case ficlInstructionNeg4:
+ case ficlInstructionNeg5:
+ case ficlInstructionNeg6:
+ case ficlInstructionNeg7:
+ case ficlInstructionNeg8:
+ case ficlInstructionNeg9:
+ case ficlInstructionNeg10:
+ case ficlInstructionNeg11:
+ case ficlInstructionNeg12:
+ case ficlInstructionNeg13:
+ case ficlInstructionNeg14:
+ case ficlInstructionNeg15:
+ case ficlInstructionNeg16:
+ {+ CHECK_STACK(0, 1);
+ (++dataTop)->i = ficlInstruction0 - instruction;
+ continue;
+ }
+
+ /**************************************************************************
+ ** stringlit: Fetch the count from the dictionary, then push the address
+ ** and count on the stack. Finally, update ip to point to the first
+ ** aligned address after the string text.
+ **************************************************************************/
+ case ficlInstructionStringLiteralParen:
+ {+ ficlUnsigned8 length;
+ CHECK_STACK(0, 2);
+
+ s = (ficlCountedString *)(ip);
+ length = s->length;
+ cp = s->text;
+ (++dataTop)->p = cp;
+ (++dataTop)->i = length;
+
+ cp += length + 1;
+ cp = ficlAlignPointer(cp);
+ ip = (void *)cp;
+ continue;
+ }
+
+ case ficlInstructionCStringLiteralParen:
+ {+ CHECK_STACK(0, 1);
+
+ s = (ficlCountedString *)(ip);
+ cp = s->text + s->length + 1;
+ cp = ficlAlignPointer(cp);
+ ip = (void *)cp;
+ (++dataTop)->p = s;
+ continue;
+ }
+
+
+#if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
+ #if FICL_WANT_FLOAT
+ FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
+ *++floatTop = cell[1];
+ /* intentional fall-through */
+ FLOAT_PUSH_CELL_POINTER_MINIPROC:
+ *++floatTop = cell[0];
+ continue;
+
+ FLOAT_POP_CELL_POINTER_MINIPROC:
+ cell[0] = *floatTop--;
+ continue;
+ FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
+ cell[0] = *floatTop--;
+ cell[1] = *floatTop--;
+ continue;
+
+ #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
+ #define FLOAT_PUSH_CELL_POINTER(cp) cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
+ #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
+ #define FLOAT_POP_CELL_POINTER(cp) cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
+ #endif /* FICL_WANT_FLOAT */
+
+ /*
+ ** Think of these as little mini-procedures.
+ ** --lch
+ */
+ PUSH_CELL_POINTER_DOUBLE_MINIPROC:
+ *++dataTop = cell[1];
+ /* intentional fall-through */
+ PUSH_CELL_POINTER_MINIPROC:
+ *++dataTop = cell[0];
+ continue;
+
+ POP_CELL_POINTER_MINIPROC:
+ cell[0] = *dataTop--;
+ continue;
+ POP_CELL_POINTER_DOUBLE_MINIPROC:
+ cell[0] = *dataTop--;
+ cell[1] = *dataTop--;
+ continue;
+
+ #define PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
+ #define PUSH_CELL_POINTER(cp) cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
+ #define POP_CELL_POINTER_DOUBLE(cp) cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
+ #define POP_CELL_POINTER(cp) cell = (cp); goto POP_CELL_POINTER_MINIPROC
+
+ BRANCH_MINIPROC:
+ ip += *(int *)ip;
+ continue;
+
+ #define BRANCH() goto BRANCH_MINIPROC
+
+ EXIT_FUNCTION_MINIPROC:
+ ip = (ficlInstruction *)((returnTop--)->p);
+ continue;
+
+ #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC
+
+#else /* FICL_WANT_SIZE */
+
+ #if FICL_WANT_FLOAT
+ #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
+ #define FLOAT_PUSH_CELL_POINTER(cp) cell = (cp); *++floatTop = *cell; continue
+ #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
+ #define FLOAT_POP_CELL_POINTER(cp) cell = (cp); *cell = *floatTop--; continue
+ #endif /* FICL_WANT_FLOAT */
+
+ #define PUSH_CELL_POINTER_DOUBLE(cp) cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
+ #define PUSH_CELL_POINTER(cp) cell = (cp); *++dataTop = *cell; continue
+ #define POP_CELL_POINTER_DOUBLE(cp) cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
+ #define POP_CELL_POINTER(cp) cell = (cp); *cell = *dataTop--; continue
+
+ #define BRANCH() ip += *(int *)ip; continue
+ #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue
+
+#endif /* FICL_WANT_SIZE */
+
+
+ /**************************************************************************
+ ** This is the runtime for (literal). It assumes that it is part of a colon
+ ** definition, and that the next ficlCell contains a value to be pushed on the
+ ** parameter stack at runtime. This code is compiled by "literal".
+ **************************************************************************/
+
+ case ficlInstructionLiteralParen:
+ {+ CHECK_STACK(0, 1);
+ (++dataTop)->i = *ip++;
+ continue;
+ }
+
+ case ficlInstruction2LiteralParen:
+ {+ CHECK_STACK(0, 2);
+ (++dataTop)->i = ip[1];
+ (++dataTop)->i = ip[0];
+ ip += 2;
+ continue;
+ }
+
+
+#if FICL_WANT_LOCALS
+ /**************************************************************************
+ ** Link a frame on the return stack, reserving nCells of space for
+ ** locals - the value of nCells is the next ficlCell in the instruction
+ ** stream.
+ ** 1) Push frame onto returnTop
+ ** 2) frame = returnTop
+ ** 3) returnTop += nCells
+ **************************************************************************/
+ case ficlInstructionLinkParen:
+ {+ ficlInteger nCells = *ip++;
+ (++returnTop)->p = frame;
+ frame = returnTop + 1;
+ returnTop += nCells;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** Unink a stack frame previously created by stackLink
+ ** 1) dataTop = frame
+ ** 2) frame = pop()
+ *******************************************************************/
+ case ficlInstructionUnlinkParen:
+ {+ returnTop = frame - 1;
+ frame = (returnTop--)->p;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** Immediate - cfa of a local while compiling - when executed, compiles
+ ** code to fetch the value of a local given the local's index in the
+ ** word's pfa
+ **************************************************************************/
+#if FICL_WANT_FLOAT
+ case ficlInstructionGetF2LocalParen:
+ FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionGetFLocalParen:
+ FLOAT_PUSH_CELL_POINTER(frame + *ip++);
+
+ case ficlInstructionToF2LocalParen:
+ FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionToFLocalParen:
+ FLOAT_POP_CELL_POINTER(frame + *ip++);
+#endif /* FICL_WANT_FLOAT */
+
+ case ficlInstructionGet2LocalParen:
+ PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionGetLocalParen:
+ PUSH_CELL_POINTER(frame + *ip++);
+
+ /**************************************************************************
+ ** Immediate - cfa of a local while compiling - when executed, compiles
+ ** code to store the value of a local given the local's index in the
+ ** word's pfa
+ **************************************************************************/
+
+ case ficlInstructionTo2LocalParen:
+ POP_CELL_POINTER_DOUBLE(frame + *ip++);
+
+ case ficlInstructionToLocalParen:
+ POP_CELL_POINTER(frame + *ip++);
+
+ /*
+ ** Silly little minor optimizations.
+ ** --lch
+ */
+ case ficlInstructionGetLocal0:
+ PUSH_CELL_POINTER(frame);
+
+ case ficlInstructionGetLocal1:
+ PUSH_CELL_POINTER(frame + 1);
+
+ case ficlInstructionGet2Local0:
+ PUSH_CELL_POINTER_DOUBLE(frame);
+
+ case ficlInstructionToLocal0:
+ POP_CELL_POINTER(frame);
+
+ case ficlInstructionToLocal1:
+ POP_CELL_POINTER(frame + 1);
+
+ case ficlInstructionTo2Local0:
+ POP_CELL_POINTER_DOUBLE(frame);
+
+#endif /* FICL_WANT_LOCALS */
+
+ case ficlInstructionPlus:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i += i;
+ continue;
+ }
+
+ case ficlInstructionMinus:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i -= i;
+ continue;
+ }
+
+ case ficlInstruction1Plus:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i++;
+ continue;
+ }
+
+ case ficlInstruction1Minus:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i--;
+ continue;
+ }
+
+ case ficlInstruction2Plus:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i += 2;
+ continue;
+ }
+
+ case ficlInstruction2Minus:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i -= 2;
+ continue;
+ }
+
+ case ficlInstructionDup:
+ {+ ficlInteger i = dataTop->i;
+ CHECK_STACK(0, 1);
+ (++dataTop)->i = i;
+ continue;
+ }
+
+ case ficlInstructionQuestionDup:
+ {+ CHECK_STACK(1, 2);
+
+ if (dataTop->i != 0)
+ {+ dataTop[1] = dataTop[0];
+ dataTop++;
+ }
+
+ continue;
+ }
+
+ case ficlInstructionSwap:
+ {+ ficlCell swap;
+ CHECK_STACK(2, 2);
+ swap = dataTop[0];
+ dataTop[0] = dataTop[-1];
+ dataTop[-1] = swap;
+ continue;
+ }
+
+ case ficlInstructionDrop:
+ {+ CHECK_STACK(1, 0);
+ dataTop--;
+ continue;
+ }
+
+
+ case ficlInstruction2Drop:
+ {+ CHECK_STACK(2, 0);
+ dataTop -= 2;
+ continue;
+ }
+
+
+ case ficlInstruction2Dup:
+ {+ CHECK_STACK(2, 4);
+ dataTop[1] = dataTop[-1];
+ dataTop[2] = *dataTop;
+ dataTop += 2;
+ continue;
+ }
+
+
+ case ficlInstructionOver:
+ {+ CHECK_STACK(2, 3);
+ dataTop[1] = dataTop[-1];
+ dataTop++;
+ continue;
+ }
+
+ case ficlInstruction2Over:
+ {+ CHECK_STACK(4, 6);
+ dataTop[1] = dataTop[-3];
+ dataTop[2] = dataTop[-2];
+ dataTop += 2;
+ continue;
+ }
+
+
+ case ficlInstructionPick:
+ {+ CHECK_STACK(1, 0);
+ i = dataTop->i;
+ if (i < 0)
+ continue;
+ CHECK_STACK(i + 1, i + 2);
+ *dataTop = dataTop[-i];
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Do stack rot.
+ ** rot ( 1 2 3 -- 2 3 1 )
+ *******************************************************************/
+ case ficlInstructionRot:
+ {+ i = 2;
+ goto ROLL;
+ }
+
+ /*******************************************************************
+ ** Do stack roll.
+ ** roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionRoll:
+ {+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+ROLL:
+ CHECK_STACK(i+1, i+2);
+ c = dataTop[-i];
+ memmove(dataTop - i, dataTop - (i - 1), i * sizeof(ficlCell));
+ *dataTop = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do stack -rot.
+ ** -rot ( 1 2 3 -- 3 1 2 )
+ *******************************************************************/
+ case ficlInstructionMinusRot:
+ {+ i = 2;
+ goto MINUSROLL;
+ }
+
+
+ /*******************************************************************
+ ** Do stack -roll.
+ ** -roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionMinusRoll:
+ {+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+MINUSROLL:
+ CHECK_STACK(i+1, i+2);
+ c = *dataTop;
+ memmove(dataTop - (i - 1), dataTop - i, i * sizeof(ficlCell));
+ dataTop[-i] = c;
+
+ continue;
+ }
+
+
+
+ /*******************************************************************
+ ** Do stack 2swap
+ ** 2swap ( 1 2 3 4 -- 3 4 1 2 )
+ *******************************************************************/
+ case ficlInstruction2Swap:
+ {+ ficlCell c2;
+ CHECK_STACK(4, 4);
+
+ c = *dataTop;
+ c2 = dataTop[-1];
+
+ *dataTop = dataTop[-2];
+ dataTop[-1] = dataTop[-3];
+
+ dataTop[-2] = c;
+ dataTop[-3] = c2;
+ continue;
+ }
+
+
+ case ficlInstructionPlusStore:
+ {+ ficlCell *cell;
+ CHECK_STACK(2, 0);
+ cell = (ficlCell *)(dataTop--)->p;
+ cell->i += (dataTop--)->i;
+ continue;
+ }
+
+
+ case ficlInstructionQuadFetch:
+ {+ ficlUnsigned32 *integer32;
+ CHECK_STACK(1, 1);
+ integer32 = (ficlUnsigned32 *)dataTop->i;
+ dataTop->u = (ficlUnsigned)*integer32;
+ continue;
+ }
+
+ case ficlInstructionQuadStore:
+ {+ ficlUnsigned32 *integer32;
+ CHECK_STACK(2, 0);
+ integer32 = (ficlUnsigned32 *)(dataTop--)->p;
+ *integer32 = (ficlUnsigned32)((dataTop--)->u);
+ continue;
+ }
+
+ case ficlInstructionWFetch:
+ {+ ficlUnsigned16 *integer16;
+ CHECK_STACK(1, 1);
+ integer16 = (ficlUnsigned16 *)dataTop->p;
+ dataTop->u = ((ficlUnsigned)*integer16);
+ continue;
+ }
+
+ case ficlInstructionWStore:
+ {+ ficlUnsigned16 *integer16;
+ CHECK_STACK(2, 0);
+ integer16 = (ficlUnsigned16 *)(dataTop--)->p;
+ *integer16 = (ficlUnsigned16)((dataTop--)->u);
+ continue;
+ }
+
+ case ficlInstructionCFetch:
+ {+ ficlUnsigned8 *integer8;
+ CHECK_STACK(1, 1);
+ integer8 = (ficlUnsigned8 *)dataTop->p;
+ dataTop->u = ((ficlUnsigned)*integer8);
+ continue;
+ }
+
+ case ficlInstructionCStore:
+ {+ ficlUnsigned8 *integer8;
+ CHECK_STACK(2, 0);
+ integer8 = (ficlUnsigned8 *)(dataTop--)->p;
+ *integer8 = (ficlUnsigned8)((dataTop--)->u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ l o g i c a n d c o m p a r i s o n s
+ **
+ **************************************************************************/
+
+ case ficlInstruction0Equals:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i == 0);
+ continue;
+ }
+
+ case ficlInstruction0Less:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i < 0);
+ continue;
+ }
+
+ case ficlInstruction0Greater:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i = FICL_BOOL(dataTop->i > 0);
+ continue;
+ }
+
+ case ficlInstructionEquals:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = FICL_BOOL(dataTop->i == i);
+ continue;
+ }
+
+ case ficlInstructionLess:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = FICL_BOOL(dataTop->i < i);
+ continue;
+ }
+
+ case ficlInstructionULess:
+ {+ CHECK_STACK(2, 1);
+ u = (dataTop--)->u;
+ dataTop->i = FICL_BOOL(dataTop->u < u);
+ continue;
+ }
+
+ case ficlInstructionAnd:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i & i;
+ continue;
+ }
+
+ case ficlInstructionOr:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i | i;
+ continue;
+ }
+
+ case ficlInstructionXor:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i = dataTop->i ^ i;
+ continue;
+ }
+
+ case ficlInstructionInvert:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i = ~dataTop->i;
+ continue;
+ }
+
+ /**************************************************************************
+ r e t u r n s t a c k
+ **
+ **************************************************************************/
+ case ficlInstructionToRStack:
+ {+ CHECK_STACK(1, 0);
+ CHECK_RETURN_STACK(0, 1);
+ *++returnTop = *dataTop--;
+ continue;
+ }
+
+ case ficlInstructionFromRStack:
+ {+ CHECK_STACK(0, 1);
+ CHECK_RETURN_STACK(1, 0);
+ *++dataTop = *returnTop--;
+ continue;
+ }
+
+ case ficlInstructionFetchRStack:
+ {+ CHECK_STACK(0, 1);
+ CHECK_RETURN_STACK(1, 1);
+ *++dataTop = *returnTop;
+ continue;
+ }
+
+ case ficlInstruction2ToR:
+ {+ CHECK_STACK(2, 0);
+ CHECK_RETURN_STACK(0, 2);
+ *++returnTop = dataTop[-1];
+ *++returnTop = dataTop[0];
+ dataTop -= 2;
+ continue;
+ }
+
+ case ficlInstruction2RFrom:
+ {+ CHECK_STACK(0, 2);
+ CHECK_RETURN_STACK(2, 0);
+ *++dataTop = returnTop[-1];
+ *++dataTop = returnTop[0];
+ returnTop -= 2;
+ continue;
+ }
+
+ case ficlInstruction2RFetch:
+ {+ CHECK_STACK(0, 2);
+ CHECK_RETURN_STACK(2, 2);
+ *++dataTop = returnTop[-1];
+ *++dataTop = returnTop[0];
+ continue;
+ }
+
+
+ /**************************************************************************
+ f i l l
+ ** CORE ( c-addr u char -- )
+ ** If u is greater than zero, store char in each of u consecutive
+ ** characters of memory beginning at c-addr.
+ **************************************************************************/
+ case ficlInstructionFill:
+ {+ char c;
+ char *memory;
+ CHECK_STACK(3, 0);
+ c = (char)(dataTop--)->i;
+ u = (dataTop--)->u;
+ memory = (char *)(dataTop--)->p;
+
+ /* memset() is faster than the previous hand-rolled solution. --lch */
+ memset(memory, c, u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ l s h i f t
+ ** l-shift CORE ( x1 u -- x2 )
+ ** Perform a logical left shift of u bit-places on x1, giving x2.
+ ** Put zeroes into the least significant bits vacated by the shift.
+ ** An ambiguous condition exists if u is greater than or equal to the
+ ** number of bits in a ficlCell.
+ **
+ ** r-shift CORE ( x1 u -- x2 )
+ ** Perform a logical right shift of u bit-places on x1, giving x2.
+ ** Put zeroes into the most significant bits vacated by the shift. An
+ ** ambiguous condition exists if u is greater than or equal to the
+ ** number of bits in a ficlCell.
+ **************************************************************************/
+ case ficlInstructionLShift:
+ {+ ficlUnsigned nBits;
+ ficlUnsigned x1;
+ CHECK_STACK(2, 1);
+
+ nBits = (dataTop--)->u;
+ x1 = dataTop->u;
+ dataTop->u = x1 << nBits;
+ continue;
+ }
+
+
+ case ficlInstructionRShift:
+ {+ ficlUnsigned nBits;
+ ficlUnsigned x1;
+ CHECK_STACK(2, 1);
+
+ nBits = (dataTop--)->u;
+ x1 = dataTop->u;
+ dataTop->u = x1 >> nBits;
+ continue;
+ }
+
+
+ /**************************************************************************
+ m a x & m i n
+ **
+ **************************************************************************/
+ case ficlInstructionMax:
+ {+ ficlInteger n2;
+ ficlInteger n1;
+ CHECK_STACK(2, 1);
+
+ n2 = (dataTop--)->i;
+ n1 = dataTop->i;
+
+ dataTop->i = ((n1 > n2) ? n1 : n2);
+ continue;
+ }
+
+ case ficlInstructionMin:
+ {+ ficlInteger n2;
+ ficlInteger n1;
+ CHECK_STACK(2, 1);
+
+ n2 = (dataTop--)->i;
+ n1 = dataTop->i;
+
+ dataTop->i = ((n1 < n2) ? n1 : n2);
+ continue;
+ }
+
+
+ /**************************************************************************
+ m o v e
+ ** CORE ( addr1 addr2 u -- )
+ ** If u is greater than zero, copy the contents of u consecutive address
+ ** units at addr1 to the u consecutive address units at addr2. After MOVE
+ ** completes, the u consecutive address units at addr2 contain exactly
+ ** what the u consecutive address units at addr1 contained before the move.
+ ** NOTE! This implementation assumes that a char is the same size as
+ ** an address unit.
+ **************************************************************************/
+ case ficlInstructionMove:
+ {+ ficlUnsigned u;
+ char *addr2;
+ char *addr1;
+ CHECK_STACK(3, 0);
+
+ u = (dataTop--)->u;
+ addr2 = (dataTop--)->p;
+ addr1 = (dataTop--)->p;
+
+ if (u == 0)
+ continue;
+ /*
+ ** Do the copy carefully, so as to be
+ ** correct even if the two ranges overlap
+ */
+ /* Which ANSI C's memmove() does for you! Yay! --lch */
+ memmove(addr2, addr1, u);
+ continue;
+ }
+
+
+ /**************************************************************************
+ s t o d
+ ** s-to-d CORE ( n -- d )
+ ** Convert the number n to the double-ficlCell number d with the same
+ ** numerical value.
+ **************************************************************************/
+ case ficlInstructionSToD:
+ {+ ficlInteger s;
+ CHECK_STACK(1, 2);
+
+ s = dataTop->i;
+
+ /* sign extend to 64 bits.. */
+ (++dataTop)->i = (s < 0) ? -1 : 0;
+ continue;
+ }
+
+
+ /**************************************************************************
+ c o m p a r e
+ ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
+ ** Compare the string specified by c-addr1 u1 to the string specified by
+ ** c-addr2 u2. The strings are compared, beginning at the given addresses,
+ ** character by character, up to the length of the shorter string or until a
+ ** difference is found. If the two strings are identical, n is zero. If the two
+ ** strings are identical up to the length of the shorter string, n is minus-one
+ ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
+ ** identical up to the length of the shorter string, n is minus-one (-1) if the
+ ** first non-matching character in the string specified by c-addr1 u1 has a
+ ** lesser numeric value than the corresponding character in the string specified
+ ** by c-addr2 u2 and one (1) otherwise.
+ **************************************************************************/
+ case ficlInstructionCompare:
+ {+ i = FICL_FALSE;
+ goto COMPARE;
+ }
+
+
+ case ficlInstructionCompareInsensitive:
+ {+ i = FICL_TRUE;
+ goto COMPARE;
+ }
+
+COMPARE:
+ {+ char *cp1, *cp2;
+ ficlUnsigned u1, u2, uMin;
+ int n = 0;
+
+ CHECK_STACK(4, 1);
+ u2 = (dataTop--)->u;
+ cp2 = (char *)(dataTop--)->p;
+ u1 = (dataTop--)->u;
+ cp1 = (char *)(dataTop--)->p;
+
+ uMin = (u1 < u2)? u1 : u2;
+ for ( ; (uMin > 0) && (n == 0); uMin--)
+ {+ char c1 = *cp1++;
+ char c2 = *cp2++;
+ if (i)
+ {+ 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;
+
+ (++dataTop)->i = n;
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** r a n d o m
+ ** Ficl-specific
+ **************************************************************************/
+ case ficlInstructionRandom:
+ {+ (++dataTop)->i = rand();
+ continue;
+ }
+
+
+ /**************************************************************************
+ ** s e e d - r a n d o m
+ ** Ficl-specific
+ **************************************************************************/
+ case ficlInstructionSeedRandom:
+ {+ srand((dataTop--)->i);
+ continue;
+ }
+
+
+
+ case ficlInstructionGreaterThan:
+ {+ ficlInteger x, y;
+ CHECK_STACK(2, 1);
+ y = (dataTop--)->i;
+ x = dataTop->i;
+ dataTop->i = FICL_BOOL(x > y);
+ continue;
+ }
+
+ /**************************************************************************
+ ** This function simply pops the previous instruction
+ ** pointer and returns to the "next" loop. Used for exiting from within
+ ** a definition. Note that exitParen is identical to semiParen - they
+ ** are in two different functions so that "see" can correctly identify
+ ** the end of a colon definition, even if it uses "exit".
+ **************************************************************************/
+ case ficlInstructionExitParen:
+ case ficlInstructionSemiParen:
+ EXIT_FUNCTION();
+
+ /**************************************************************************
+ ** The first time we run "(branch)", perform a "peephole optimization" to
+ ** see if we're jumping to another unconditional jump. If so, just jump
+ ** directly there.
+ **************************************************************************/
+ case ficlInstructionBranchParenWithCheck:
+ {+ LOCAL_VARIABLE_SPILL;
+ ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
+ LOCAL_VARIABLE_REFILL;
+ goto BRANCH_PAREN;
+ }
+
+ /**************************************************************************
+ ** Same deal with branch0.
+ **************************************************************************/
+ case ficlInstructionBranch0ParenWithCheck:
+ {+ LOCAL_VARIABLE_SPILL;
+ ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
+ LOCAL_VARIABLE_REFILL;
+ /* intentional fall-through */
+ }
+
+ /**************************************************************************
+ ** Runtime code for "(branch0)"; pop a flag from the stack,
+ ** branch if 0. fall through otherwise. The heart of "if" and "until".
+ **************************************************************************/
+ case ficlInstructionBranch0Paren:
+ {+ CHECK_STACK(1, 0);
+
+ if ((dataTop--)->i)
+ {+ /* don't branch, but skip over branch relative address */
+ ip += 1;
+ continue;
+ }
+ /* otherwise, take branch (to else/endif/begin) */
+ /* intentional fall-through! */
+ }
+
+ /**************************************************************************
+ ** Runtime for "(branch)" -- expects a literal offset in the next
+ ** compilation address, and branches to that location.
+ **************************************************************************/
+ case ficlInstructionBranchParen:
+ {+BRANCH_PAREN:
+ BRANCH();
+ }
+
+ case ficlInstructionOfParen:
+ {+ ficlUnsigned a, b;
+
+ CHECK_STACK(2, 1);
+
+ a = (dataTop--)->u;
+ b = dataTop->u;
+
+ if (a == b)
+ {+ /* fall through */
+ ip++;
+ /* remove CASE argument */
+ dataTop--;
+ }
+ else
+ {+ /* take branch to next of or endcase */
+ BRANCH();
+ }
+
+ continue;
+ }
+
+ case ficlInstructionDoParen:
+ {+ ficlCell index, limit;
+
+ CHECK_STACK(2, 0);
+
+ index = *dataTop--;
+ limit = *dataTop--;
+
+ /* copy "leave" target addr to stack */
+ (++returnTop)->i = *(ip++);
+ *++returnTop = limit;
+ *++returnTop = index;
+
+ continue;
+ }
+
+ case ficlInstructionQDoParen:
+ {+ ficlCell index, limit, leave;
+
+ CHECK_STACK(2, 0);
+
+ index = *dataTop--;
+ limit = *dataTop--;
+
+ leave.i = *ip;
+
+ if (limit.u == index.u)
+ {+ ip = leave.p;
+ }
+ else
+ {+ ip++;
+ *++returnTop = leave;
+ *++returnTop = limit;
+ *++returnTop = index;
+ }
+
+ continue;
+ }
+
+ case ficlInstructionLoopParen:
+ case ficlInstructionPlusLoopParen:
+ {+ ficlInteger index;
+ ficlInteger limit;
+ int direction = 0;
+
+ index = returnTop->i;
+ limit = returnTop[-1].i;
+
+ if (instruction == ficlInstructionLoopParen)
+ index++;
+ else
+ {+ ficlInteger increment;
+ CHECK_STACK(1, 0);
+ increment = (dataTop--)->i;
+ index += increment;
+ direction = (increment < 0);
+ }
+
+ if (direction ^ (index >= limit))
+ {+ returnTop -= 3; /* nuke the loop indices & "leave" addr */
+ ip++; /* fall through the loop */
+ }
+ else
+ { /* update index, branch to loop head */+ returnTop->i = index;
+ BRANCH();
+ }
+
+ continue;
+ }
+
+
+ /*
+ ** Runtime code to break out of a do..loop construct
+ ** Drop the loop control variables; the branch address
+ ** past "loop" is next on the return stack.
+ */
+ case ficlInstructionLeave:
+ {+ /* almost unloop */
+ returnTop -= 2;
+ /* exit */
+ EXIT_FUNCTION();
+ }
+
+
+ case ficlInstructionUnloop:
+ {+ returnTop -= 3;
+ continue;
+ }
+
+ case ficlInstructionI:
+ {+ *++dataTop = *returnTop;
+ continue;
+ }
+
+
+ case ficlInstructionJ:
+ {+ *++dataTop = returnTop[-3];
+ continue;
+ }
+
+
+ case ficlInstructionK:
+ {+ *++dataTop = returnTop[-6];
+ continue;
+ }
+
+
+ case ficlInstructionDoesParen:
+ {+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ dictionary->smudge->code = (ficlPrimitive)ficlInstructionDoDoes;
+ dictionary->smudge->param[0].p = ip;
+ ip = (ficlInstruction *)((returnTop--)->p);
+ continue;
+ }
+
+ case ficlInstructionDoDoes:
+ {+ ficlCell *cell;
+ ficlIp tempIP;
+
+ CHECK_STACK(0, 1);
+
+ cell = fw->param;
+ tempIP = (ficlIp)((*cell).p);
+ (++dataTop)->p = (cell + 1);
+ (++returnTop)->p = (void *)ip;
+ ip = (ficlInstruction *)tempIP;
+ continue;
+ }
+
+#if FICL_WANT_FLOAT
+ case ficlInstructionF2Fetch:
+ CHECK_FLOAT_STACK(0, 2);
+ CHECK_STACK(1, 0);
+ FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ case ficlInstructionFFetch:
+ CHECK_FLOAT_STACK(0, 1);
+ CHECK_STACK(1, 0);
+ FLOAT_PUSH_CELL_POINTER((dataTop--)->p);
+
+ case ficlInstructionF2Store:
+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(1, 0);
+ FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ case ficlInstructionFStore:
+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(1, 0);
+ FLOAT_POP_CELL_POINTER((dataTop--)->p);
+#endif /* FICL_WANT_FLOAT */
+
+ /*
+ ** two-fetch CORE ( a-addr -- x1 x2 )
+ **
+ ** Fetch the ficlCell pair x1 x2 stored at a-addr. x2 is stored at a-addr
+ ** and x1 at the next consecutive ficlCell. It is equivalent to the
+ ** sequence DUP ficlCell+ @ SWAP @ .
+ */
+ case ficlInstruction2Fetch:
+ CHECK_STACK(1, 2);
+ PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ /*
+ ** fetch CORE ( a-addr -- x )
+ **
+ ** x is the value stored at a-addr.
+ */
+ case ficlInstructionFetch:
+ CHECK_STACK(1, 1);
+ PUSH_CELL_POINTER((dataTop--)->p);
+
+ /*
+ ** two-store CORE ( x1 x2 a-addr -- )
+ ** Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
+ ** next consecutive ficlCell. It is equivalent to the sequence
+ ** SWAP OVER ! ficlCell+ ! .
+ */
+ case ficlInstruction2Store:
+ CHECK_STACK(3, 0);
+ POP_CELL_POINTER_DOUBLE((dataTop--)->p);
+
+ /*
+ ** store CORE ( x a-addr -- )
+ ** Store x at a-addr.
+ */
+ case ficlInstructionStore:
+ CHECK_STACK(2, 0);
+ POP_CELL_POINTER((dataTop--)->p);
+
+ case ficlInstructionComma:
+ {+ ficlDictionary *dictionary;
+ CHECK_STACK(1, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ ficlDictionaryAppendCell(dictionary, *dataTop--);
+ continue;
+ }
+
+ case ficlInstructionCComma:
+ {+ ficlDictionary *dictionary;
+ char c;
+ CHECK_STACK(1, 0);
+
+ dictionary = ficlVmGetDictionary(vm);
+ c = (char)(dataTop--)->i;
+ ficlDictionaryAppendCharacter(dictionary, c);
+ continue;
+ }
+
+ case ficlInstructionCells:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i *= sizeof(ficlCell);
+ continue;
+ }
+
+ case ficlInstructionCellPlus:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i += sizeof(ficlCell);
+ continue;
+ }
+
+ case ficlInstructionStar:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i *= i;
+ continue;
+ }
+
+ case ficlInstructionNegate:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i = - dataTop->i;
+ continue;
+ }
+
+ case ficlInstructionSlash:
+ {+ CHECK_STACK(2, 1);
+ i = (dataTop--)->i;
+ dataTop->i /= i;
+ continue;
+ }
+
+ /*
+ ** slash-mod CORE ( n1 n2 -- n3 n4 )
+ ** Divide n1 by n2, giving the single-ficlCell remainder n3 and the single-ficlCell
+ ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
+ ** differ in sign, the implementation-defined result returned will be the
+ ** same as that returned by either the phrase
+ ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
+ ** NOTE: Ficl complies with the second phrase (symmetric division)
+ */
+ case ficlInstructionSlashMod:
+ {+ ficl2Integer n1;
+ ficlInteger n2;
+ ficl2IntegerQR qr;
+
+ CHECK_STACK(2, 2);
+ n2 = dataTop[0].i;
+ FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1);
+
+ qr = ficl2IntegerDivideSymmetric(n1, n2);
+ dataTop[-1].i = qr.remainder;
+ dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
+ continue;
+ }
+
+
+ case ficlInstruction2Star:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i <<= 1;
+ continue;
+ }
+
+ case ficlInstruction2Slash:
+ {+ CHECK_STACK(1, 1);
+ dataTop->i >>= 1;
+ continue;
+ }
+
+ case ficlInstructionStarSlash:
+ {+ ficlInteger x, y, z;
+ ficl2Integer prod;
+ CHECK_STACK(3, 1);
+
+ z = (dataTop--)->i;
+ y = (dataTop--)->i;
+ x = dataTop->i;
+
+ prod = ficl2IntegerMultiply(x,y);
+ dataTop->i = FICL_2UNSIGNED_GET_LOW(ficl2IntegerDivideSymmetric(prod, z).quotient);
+ continue;
+ }
+
+
+ case ficlInstructionStarSlashMod:
+ {+ ficlInteger x, y, z;
+ ficl2Integer prod;
+ ficl2IntegerQR qr;
+
+ CHECK_STACK(3, 2);
+
+ z = (dataTop--)->i;
+ y = dataTop[0].i;
+ x = dataTop[-1].i;
+
+ prod = ficl2IntegerMultiply(x,y);
+ qr = ficl2IntegerDivideSymmetric(prod, z);
+
+ dataTop[-1].i = qr.remainder;
+ dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
+ continue;
+ }
+
+
+#if FICL_WANT_FLOAT
+
+ case ficlInstructionF0:
+ {+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = 0.0f;
+ continue;
+ }
+
+
+ case ficlInstructionF1:
+ {+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = 1.0f;
+ continue;
+ }
+
+
+ case ficlInstructionFNeg1:
+ {+ CHECK_FLOAT_STACK(0, 1);
+ (++floatTop)->f = -1.0f;
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Floating point literal execution word.
+ *******************************************************************/
+ case ficlInstructionFLiteralParen:
+ {+ CHECK_FLOAT_STACK(0, 1);
+
+ /* Yes, I'm using ->i here, but it's really a float. --lch */
+ (++floatTop)->i = *ip++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float addition r1 + r2.
+ ** f+ ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFPlus:
+ {+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f += f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float subtraction r1 - r2.
+ ** f- ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFMinus:
+ {+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f -= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float multiplication r1 * r2.
+ ** f* ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFStar:
+ {+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f *= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float negation.
+ ** fnegate ( r -- r )
+ *******************************************************************/
+ case ficlInstructionFNegate:
+ {+ CHECK_FLOAT_STACK(1, 1);
+
+ floatTop->f = -(floatTop->f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float division r1 / r2.
+ ** f/ ( r1 r2 -- r )
+ *******************************************************************/
+ case ficlInstructionFSlash:
+ {+ CHECK_FLOAT_STACK(2, 1);
+
+ f = (floatTop--)->f;
+ floatTop->f /= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float + integer r + n.
+ ** f+i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFPlusI:
+ {+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f += f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float - integer r - n.
+ ** f-i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFMinusI:
+ {+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f -= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float * integer r * n.
+ ** f*i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFStarI:
+ {+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f *= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float / integer r / n.
+ ** f/i ( r n -- r )
+ *******************************************************************/
+ case ficlInstructionFSlashI:
+ {+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f /= f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer - float n - r.
+ ** i-f ( n r -- r )
+ *******************************************************************/
+ case ficlInstructionIMinusF:
+ {+ CHECK_FLOAT_STACK(1, 1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f = f - floatTop->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer / float n / r.
+ ** i/f ( n r -- r )
+ *******************************************************************/
+ case ficlInstructionISlashF:
+ {+ CHECK_FLOAT_STACK(1,1);
+ CHECK_STACK(1, 0);
+
+ f = (ficlFloat)(dataTop--)->f;
+ floatTop->f = f / floatTop->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do integer to float conversion.
+ ** int>float ( n -- r )
+ *******************************************************************/
+ case ficlInstructionIntToFloat:
+ {+ CHECK_STACK(1, 0);
+ CHECK_FLOAT_STACK(0, 1);
+
+ (++floatTop)->f = (ficlFloat)((dataTop--)->i);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float to integer conversion.
+ ** float>int ( r -- n )
+ *******************************************************************/
+ case ficlInstructionFloatToInt:
+ {+ CHECK_STACK(0, 1);
+ CHECK_FLOAT_STACK(1, 0);
+
+ (++dataTop)->i = (ficlInteger)((floatTop--)->f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Add a floating point number to contents of a variable.
+ ** f+! ( r n -- )
+ *******************************************************************/
+ case ficlInstructionFPlusStore:
+ {+ ficlCell *cell;
+
+ CHECK_STACK(1, 0);
+ CHECK_FLOAT_STACK(1, 0);
+
+ cell = (ficlCell *)(dataTop--)->p;
+ cell->f += (floatTop--)->f;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack drop.
+ ** fdrop ( r -- )
+ *******************************************************************/
+ case ficlInstructionFDrop:
+ {+ CHECK_FLOAT_STACK(1, 0);
+ floatTop--;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack ?dup.
+ ** f?dup ( r -- r )
+ *******************************************************************/
+ case ficlInstructionFQuestionDup:
+ {+ CHECK_FLOAT_STACK(1, 2);
+
+ if (floatTop->f != 0)
+ goto FDUP;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack dup.
+ ** fdup ( r -- r r )
+ *******************************************************************/
+ case ficlInstructionFDup:
+ {+ CHECK_FLOAT_STACK(1, 2);
+
+FDUP:
+ floatTop[1] = floatTop[0];
+ floatTop++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack swap.
+ ** fswap ( r1 r2 -- r2 r1 )
+ *******************************************************************/
+ case ficlInstructionFSwap:
+ {+ CHECK_FLOAT_STACK(2, 2);
+
+ c = floatTop[0];
+ floatTop[0] = floatTop[-1];
+ floatTop[-1] = c;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2drop.
+ ** f2drop ( r r -- )
+ *******************************************************************/
+ case ficlInstructionF2Drop:
+ {+ CHECK_FLOAT_STACK(2, 0);
+
+ floatTop -= 2;
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Do float stack 2dup.
+ ** f2dup ( r1 r2 -- r1 r2 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Dup:
+ {+ CHECK_FLOAT_STACK(2, 4);
+
+ floatTop[1] = floatTop[-1];
+ floatTop[2] = *floatTop;
+ floatTop += 2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack over.
+ ** fover ( r1 r2 -- r1 r2 r1 )
+ *******************************************************************/
+ case ficlInstructionFOver:
+ {+ CHECK_FLOAT_STACK(2, 3);
+
+ floatTop[1] = floatTop[-1];
+ floatTop++;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2over.
+ ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Over:
+ {+ CHECK_FLOAT_STACK(4, 6);
+
+ floatTop[1] = floatTop[-2];
+ floatTop[2] = floatTop[-1];
+ floatTop += 2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack pick.
+ ** fpick ( n -- r )
+ *******************************************************************/
+ case ficlInstructionFPick:
+ {+ CHECK_STACK(1, 0);
+ c = *dataTop--;
+ CHECK_FLOAT_STACK(c.i+1, c.i+2);
+
+ floatTop[1] = floatTop[- c.i];
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack rot.
+ ** frot ( r1 r2 r3 -- r2 r3 r1 )
+ *******************************************************************/
+ case ficlInstructionFRot:
+ {+ i = 2;
+ goto FROLL;
+ }
+
+ /*******************************************************************
+ ** Do float stack roll.
+ ** froll ( n -- )
+ *******************************************************************/
+ case ficlInstructionFRoll:
+ {+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+FROLL:
+ CHECK_FLOAT_STACK(i+1, i+2);
+ c = floatTop[-i];
+ memmove(floatTop - i, floatTop - (i - 1), i * sizeof(ficlCell));
+ *floatTop = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack -rot.
+ ** f-rot ( r1 r2 r3 -- r3 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionFMinusRot:
+ {+ i = 2;
+ goto FMINUSROLL;
+ }
+
+
+ /*******************************************************************
+ ** Do float stack -roll.
+ ** f-roll ( n -- )
+ *******************************************************************/
+ case ficlInstructionFMinusRoll:
+ {+ CHECK_STACK(1, 0);
+ i = (dataTop--)->i;
+
+ if (i < 1)
+ continue;
+
+FMINUSROLL:
+ CHECK_FLOAT_STACK(i+1, i+2);
+ c = *floatTop;
+ memmove(floatTop - (i - 1), floatTop - i, i * sizeof(ficlCell));
+ floatTop[-i] = c;
+
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float stack 2swap
+ ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
+ *******************************************************************/
+ case ficlInstructionF2Swap:
+ {+ ficlCell c2;
+ CHECK_FLOAT_STACK(4, 4);
+
+ c = *floatTop;
+ c2 = floatTop[-1];
+
+ *floatTop = floatTop[-2];
+ floatTop[-1] = floatTop[-3];
+
+ floatTop[-2] = c;
+ floatTop[-3] = c2;
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0= comparison r = 0.0.
+ ** f0= ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Equals:
+ {+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0< comparison r < 0.0.
+ ** f0< ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Less:
+ {+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float 0> comparison r > 0.0.
+ ** f0> ( r -- T/F )
+ *******************************************************************/
+ case ficlInstructionF0Greater:
+ {+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float = comparison r1 = r2.
+ ** f= ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFEquals:
+ {+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f == f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float < comparison r1 < r2.
+ ** f< ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFLess:
+ {+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f < f);
+ continue;
+ }
+
+ /*******************************************************************
+ ** Do float > comparison r1 > r2.
+ ** f> ( r1 r2 -- T/F )
+ *******************************************************************/
+ case ficlInstructionFGreater:
+ {+ CHECK_FLOAT_STACK(2, 0);
+ CHECK_STACK(0, 1);
+
+ f = (floatTop--)->f;
+ (++dataTop)->i = FICL_BOOL((floatTop--)->f > f);
+ continue;
+ }
+
+
+ /*******************************************************************
+ ** Move float to param stack (assumes they both fit in a single ficlCell)
+ ** f>s
+ *******************************************************************/
+ case ficlInstructionFFrom:
+ {+ CHECK_FLOAT_STACK(1, 0);
+ CHECK_STACK(0, 1);
+
+ *++dataTop = *floatTop--;
+ continue;
+ }
+
+ case ficlInstructionToF:
+ {+ CHECK_FLOAT_STACK(0, 1);
+ CHECK_STACK(1, 0);
+
+ *++floatTop = *dataTop--;
+ continue;
+ }
+
+#endif /* FICL_WANT_FLOAT */
+
+
+ /**************************************************************************
+ c o l o n P a r e n
+ ** This is the code that executes a colon definition. It assumes that the
+ ** virtual machine is running a "next" loop (See the vm.c
+ ** for its implementation of member function vmExecute()). The colon
+ ** code simply copies the address of the first word in the list of words
+ ** to interpret into IP after saving its old value. When we return to the
+ ** "next" loop, the virtual machine will call the code for each word in
+ ** turn.
+ **
+ **************************************************************************/
+ case ficlInstructionColonParen:
+ {+ (++returnTop)->p = (void *)ip;
+ ip = (ficlInstruction *)(fw->param);
+ continue;
+ }
+
+ case ficlInstructionCreateParen:
+ {+ CHECK_STACK(0, 1);
+ (++dataTop)->p = (fw->param + 1);
+ continue;
+ }
+
+ case ficlInstructionVariableParen:
+ {+ CHECK_STACK(0, 1);
+ (++dataTop)->p = fw->param;
+ continue;
+ }
+
+ /**************************************************************************
+ c o n s t a n t P a r e n
+ ** This is the run-time code for "constant". It simply returns the
+ ** contents of its word's first data ficlCell.
+ **
+ **************************************************************************/
+
+
+#if FICL_WANT_FLOAT
+ case ficlInstructionF2ConstantParen:
+ CHECK_FLOAT_STACK(0, 2);
+ FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param);
+
+ case ficlInstructionFConstantParen:
+ CHECK_FLOAT_STACK(0, 1);
+ FLOAT_PUSH_CELL_POINTER(fw->param);
+#endif /* FICL_WANT_FLOAT */
+
+ case ficlInstruction2ConstantParen:
+ CHECK_STACK(0, 2);
+ PUSH_CELL_POINTER_DOUBLE(fw->param);
+
+ case ficlInstructionConstantParen:
+ CHECK_STACK(0, 1);
+ PUSH_CELL_POINTER(fw->param);
+
+
+#if FICL_WANT_USER
+ case ficlInstructionUserParen:
+ {+ ficlInteger i = fw->param[0].i;
+ (++dataTop)->p = &vm->user[i];
+ continue;
+ }
+#endif
+
+ default:
+ {+ /*
+ ** Clever hack, or evil coding? You be the judge.
+ **
+ ** If the word we've been asked to execute is in fact
+ ** an *instruction*, we grab the instruction, stow it
+ ** in "i" (our local cache of *ip), and *jump* to the
+ ** top of the switch statement. --lch
+ */
+ if ((ficlInstruction)fw->code < ficlInstructionLast)
+ {+ instruction = (int)fw->code;
+ goto AGAIN;
+ }
+
+ LOCAL_VARIABLE_SPILL;
+ (vm)->runningWord = fw;
+ fw->code(vm);
+ LOCAL_VARIABLE_REFILL;
+ continue;
+ }
+ }
+ }
+
+ LOCAL_VARIABLE_SPILL;
+ vm->exceptionHandler = oldExceptionHandler;
+}
+
+
+/**************************************************************************
+ v m G e t D i c t
+** Returns the address dictionary for this VM's system
+**************************************************************************/
+ficlDictionary *ficlVmGetDictionary(ficlVm *vm)
+{+ FICL_VM_ASSERT(vm, vm);
+ return vm->callback.system->dictionary;
+}
+
+
+/**************************************************************************
+ v m G e t S t r i n g
+** Parses a string out of the VM input buffer and copies up to the first
+** FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a
+** ficlCountedString. The destination string is NULL terminated.
+**
+** Returns the address of the first unused character in the dest buffer.
+**************************************************************************/
+char *ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter)
+{+ ficlString s = ficlVmParseStringEx(vm, delimiter, 0);
+
+ if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX)
+ {+ FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX);
+ }
+
+ strncpy(counted->text, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
+ counted->text[FICL_STRING_GET_LENGTH(s)] = '\0';
+ counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
+
+ return counted->text + FICL_STRING_GET_LENGTH(s) + 1;
+}
+
+
+/**************************************************************************
+ v m G e t W o r d
+** vmGetWord calls vmGetWord0 repeatedly until it gets a string with
+** non-zero length.
+**************************************************************************/
+ficlString ficlVmGetWord(ficlVm *vm)
+{+ ficlString s = ficlVmGetWord0(vm);
+
+ if (FICL_STRING_GET_LENGTH(s) == 0)
+ {+ ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
+ }
+
+ return s;
+}
+
+
+/**************************************************************************
+ 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.
+**************************************************************************/
+ficlString ficlVmGetWord0(ficlVm *vm)
+{+ char *trace = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ ficlString s;
+ ficlUnsigned length = 0;
+ char c = 0;
+
+ trace = ficlStringSkipSpace(trace, stop);
+ FICL_STRING_SET_POINTER(s, trace);
+
+
+ /* Please leave this loop this way; it makes Purify happier. --lch */
+ for (;;)
+ {+ if (trace == stop)
+ break;
+ c = *trace;
+ if (isspace(c))
+ break;
+ length++;
+ trace++;
+ }
+
+ FICL_STRING_SET_LENGTH(s, length);
+
+ if ((trace != stop) && isspace(c)) /* skip one trailing delimiter */
+ trace++;
+
+ ficlVmUpdateTib(vm, trace);
+
+ return s;
+}
+
+
+/**************************************************************************
+ 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 ficlVmGetWordToPad(ficlVm *vm)
+{+ ficlString s;
+ char *pad = (char *)vm->pad;
+ s = ficlVmGetWord(vm);
+
+ if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE)
+ FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE);
+
+ strncpy(pad, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s));
+ pad[FICL_STRING_GET_LENGTH(s)] = '\0';
+ return (int)(FICL_STRING_GET_LENGTH(s));
+}
+
+
+/**************************************************************************
+ 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.
+**************************************************************************/
+ficlString ficlVmParseString(ficlVm *vm, char delimiter)
+{ + return ficlVmParseStringEx(vm, delimiter, 1);
+}
+
+ficlString ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
+{+ ficlString s;
+ char *trace = ficlVmGetInBuf(vm);
+ char *stop = ficlVmGetInBufEnd(vm);
+ char c;
+
+ if (skipLeadingDelimiters)
+ {+ while ((trace != stop) && (*trace == delimiter))
+ trace++;
+ }
+
+ FICL_STRING_SET_POINTER(s, trace); /* mark start of text */
+
+ for (c = *trace;
+ (trace != stop) && (c != delimiter)
+ && (c != '\r') && (c != '\n');
+ c = *++trace)
+ {+ ; /* find next delimiter or end of line */
+ }
+
+ /* set length of result */
+ FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));
+
+ if ((trace != stop) && (*trace == delimiter)) /* gobble trailing delimiter */
+ trace++;
+
+ ficlVmUpdateTib(vm, trace);
+ return s;
+}
+
+
+/**************************************************************************
+ v m P o p
+**
+**************************************************************************/
+ficlCell ficlVmPop(ficlVm *vm)
+{+ return ficlStackPop(vm->dataStack);
+}
+
+
+/**************************************************************************
+ v m P u s h
+**
+**************************************************************************/
+void ficlVmPush(ficlVm *vm, ficlCell c)
+{+ ficlStackPush(vm->dataStack, c);
+ return;
+}
+
+
+/**************************************************************************
+ v m P o p I P
+**
+**************************************************************************/
+void ficlVmPopIP(ficlVm *vm)
+{+ vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
+ return;
+}
+
+
+/**************************************************************************
+ v m P u s h I P
+**
+**************************************************************************/
+void ficlVmPushIP(ficlVm *vm, ficlIp newIP)
+{+ ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
+ vm->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 ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
+{+ if (pSaveTib)
+ {+ *pSaveTib = vm->tib;
+ }
+
+ vm->tib.text = text;
+ vm->tib.end = text + nChars;
+ vm->tib.index = 0;
+}
+
+
+void ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
+{+ if (pTib)
+ {+ vm->tib = *pTib;
+ }
+ return;
+}
+
+
+/**************************************************************************
+ v m Q u i t
+**
+**************************************************************************/
+void ficlVmQuit(ficlVm *vm)
+{+ ficlStackReset(vm->returnStack);
+ vm->restart = 0;
+ vm->ip = NULL;
+ vm->runningWord = NULL;
+ vm->state = FICL_VM_STATE_INTERPRET;
+ vm->tib.text = NULL;
+ vm->tib.end = NULL;
+ vm->tib.index = 0;
+ vm->pad[0] = '\0';
+ vm->sourceId.i = 0;
+ return;
+}
+
+
+/**************************************************************************
+ v m R e s e t
+**
+**************************************************************************/
+void ficlVmReset(ficlVm *vm)
+{+ ficlVmQuit(vm);
+ ficlStackReset(vm->dataStack);
+#if FICL_WANT_FLOAT
+ ficlStackReset(vm->floatStack);
+#endif
+ vm->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 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
+{+ vm->callback.textOut = textOut;
+ return;
+}
+
+
+void ficlVmTextOut(ficlVm *vm, char *text)
+ {+ ficlCallbackTextOut((ficlCallback *)vm, text);
+ }
+
+
+void ficlVmErrorOut(ficlVm *vm, char *text)
+ {+ ficlCallbackErrorOut((ficlCallback *)vm, text);
+ }
+
+
+ /**************************************************************************
+ v m T h r o w
+**
+**************************************************************************/
+void ficlVmThrow(ficlVm *vm, int except)
+{+ if (vm->exceptionHandler)
+ longjmp(*(vm->exceptionHandler), except);
+}
+
+
+void ficlVmThrowError(ficlVm *vm, char *fmt, ...)
+{+ va_list list;
+
+ va_start(list, fmt);
+ vsprintf(vm->pad, fmt, list);
+ va_end(list);
+ strcat(vm->pad, "\n");
+
+ ficlVmErrorOut(vm, vm->pad);
+ longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
+}
+
+
+void ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
+{+ vsprintf(vm->pad, fmt, list);
+ /* well, we can try anyway, we're certainly not returning to our caller! */
+ va_end(list);
+ strcat(vm->pad, "\n");
+
+ ficlVmErrorOut(vm, vm->pad);
+ longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
+}
+
+
+/**************************************************************************
+ f i c l E v a l u a t e
+** Wrapper for ficlExec() which sets SOURCE-ID to -1.
+**************************************************************************/
+int ficlVmEvaluate(ficlVm *vm, char *s)
+{+ int returnValue;
+ ficlCell id = vm->sourceId;
+ ficlString string;
+ vm->sourceId.i = -1;
+ FICL_STRING_SET_FROM_CSTRING(string, s);
+ returnValue = ficlVmExecuteString(vm, string);
+ vm->sourceId = id;
+ return returnValue;
+}
+
+
+/**************************************************************************
+ f i c l E x e c
+** Evaluates a block of input text in the context of the
+** specified interpreter. Emits any requested output to the
+** interpreter's output function.
+**
+** Contains the "inner interpreter" code in a tight loop
+**
+** Returns one of the VM_XXXX codes defined in ficl.h:
+** VM_OUTOFTEXT is the normal exit condition
+** VM_ERREXIT means that the interpreter encountered a syntax error
+** and the vm has been reset to recover (some or all
+** of the text block got ignored
+** VM_USEREXIT means that the user executed the "bye" command
+** to shut down the interpreter. This would be a good
+** time to delete the vm, etc -- or you can ignore this
+** signal.
+**************************************************************************/
+int ficlVmExecuteString(ficlVm *vm, ficlString s)
+{+ ficlSystem *system = vm->callback.system;
+ ficlDictionary *dictionary = system->dictionary;
+
+ int except;
+ jmp_buf vmState;
+ jmp_buf *oldState;
+ ficlTIB saveficlTIB;
+
+ FICL_VM_ASSERT(vm, vm);
+ FICL_VM_ASSERT(vm, system->interpreterLoop[0]);
+
+ ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s), FICL_STRING_GET_LENGTH(s), &saveficlTIB);
+
+ /*
+ ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
+ */
+ oldState = vm->exceptionHandler;
+ vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */
+ except = setjmp(vmState);
+
+ switch (except)
+ {+ case 0:
+ if (vm->restart)
+ {+ vm->runningWord->code(vm);
+ vm->restart = 0;
+ }
+ else
+ { /* set VM up to interpret text */+ ficlVmPushIP(vm, &(system->interpreterLoop[0]));
+ }
+
+ ficlVmInnerLoop(vm, 0);
+ break;
+
+ case FICL_VM_STATUS_RESTART:
+ vm->restart = 1;
+ except = FICL_VM_STATUS_OUT_OF_TEXT;
+ break;
+
+ case FICL_VM_STATUS_OUT_OF_TEXT:
+ ficlVmPopIP(vm);
+ if ((vm->state != FICL_VM_STATE_COMPILE) && (vm->sourceId.i == 0))
+ ficlVmTextOut(vm, FICL_PROMPT);
+ break;
+
+ case FICL_VM_STATUS_USER_EXIT:
+ case FICL_VM_STATUS_INNER_EXIT:
+ case FICL_VM_STATUS_BREAK:
+ break;
+
+ case FICL_VM_STATUS_QUIT:
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ {+ ficlDictionaryAbortDefinition(dictionary);
+#if FICL_WANT_LOCALS
+ ficlDictionaryEmpty(system->locals, system->locals->forthWordlist->size);
+#endif
+ }
+ ficlVmQuit(vm);
+ break;
+
+ case FICL_VM_STATUS_ERROR_EXIT:
+ case FICL_VM_STATUS_ABORT:
+ case FICL_VM_STATUS_ABORTQ:
+ default: /* user defined exit code?? */
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ {+ ficlDictionaryAbortDefinition(dictionary);
+#if FICL_WANT_LOCALS
+ ficlDictionaryEmpty(system->locals, system->locals->forthWordlist->size);
+#endif
+ }
+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmReset(vm);
+ break;
+ }
+
+ vm->exceptionHandler = oldState;
+ ficlVmPopTib(vm, &saveficlTIB);
+ return (except);
+}
+
+
+/**************************************************************************
+ f i c l E x e c X T
+** Given a pointer to a ficlWord, push an inner interpreter and
+** execute the word to completion. This is in contrast with vmExecute,
+** which does not guarantee that the word will have completed when
+** the function returns (ie in the case of colon definitions, which
+** need an inner interpreter to finish)
+**
+** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
+** exit condition is VM_INNEREXIT, Ficl's private signal to exit the
+** inner loop under normal circumstances. If another code is thrown to
+** exit the loop, this function will re-throw it if it's nested under
+** itself or ficlExec.
+**
+** NOTE: this function is intended so that C code can execute ficlWords
+** given their address in the dictionary (xt).
+**************************************************************************/
+int ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
+{+ int except;
+ jmp_buf vmState;
+ jmp_buf *oldState;
+ ficlWord *oldRunningWord;
+
+ FICL_VM_ASSERT(vm, vm);
+ FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
+
+ /*
+ ** Save the runningword so that RESTART behaves correctly
+ ** over nested calls.
+ */
+ oldRunningWord = vm->runningWord;
+ /*
+ ** Save and restore VM's jmp_buf to enable nested calls
+ */
+ oldState = vm->exceptionHandler;
+ vm->exceptionHandler = &vmState; /* This has to come before the setjmp! */
+ except = setjmp(vmState);
+
+ if (except)
+ ficlVmPopIP(vm);
+ else
+ ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
+
+ switch (except)
+ {+ case 0:
+ ficlVmExecuteWord(vm, pWord);
+ ficlVmInnerLoop(vm, 0);
+ break;
+
+ case FICL_VM_STATUS_INNER_EXIT:
+ case FICL_VM_STATUS_BREAK:
+ break;
+
+ case FICL_VM_STATUS_RESTART:
+ case FICL_VM_STATUS_OUT_OF_TEXT:
+ case FICL_VM_STATUS_USER_EXIT:
+ case FICL_VM_STATUS_QUIT:
+ case FICL_VM_STATUS_ERROR_EXIT:
+ case FICL_VM_STATUS_ABORT:
+ case FICL_VM_STATUS_ABORTQ:
+ default: /* user defined exit code?? */
+ if (oldState)
+ {+ vm->exceptionHandler = oldState;
+ ficlVmThrow(vm, except);
+ }
+ break;
+ }
+
+ vm->exceptionHandler = oldState;
+ vm->runningWord = oldRunningWord;
+ return (except);
+}
+
+
+/**************************************************************************
+ f i c l P a r s e N u m b e r
+** Attempts to convert the NULL terminated string in the VM's pad to
+** a number using the VM's current base. If successful, pushes the number
+** onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE.
+** (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
+** the standard for DOUBLE wordset.
+**************************************************************************/
+
+int ficlVmParseNumber(ficlVm *vm, ficlString s)
+{+ ficlInteger accumulator = 0;
+ char isNegative = 0;
+ char isDouble = 0;
+ unsigned base = vm->base;
+ char *trace = FICL_STRING_GET_POINTER(s);
+ ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
+ unsigned c;
+ unsigned digit;
+
+ if (length > 1)
+ {+ switch (*trace)
+ {+ case '-':
+ trace++;
+ length--;
+ isNegative = 1;
+ break;
+ case '+':
+ trace++;
+ length--;
+ isNegative = 0;
+ break;
+ default:
+ break;
+ }
+ }
+
+ if ((length > 0) && (trace[length - 1] == '.')) /* detect & remove trailing decimal */
+ {+ isDouble = 1;
+ length--;
+ }
+
+ if (length == 0) /* detect "+", "-", ".", "+." etc */
+ return FICL_FALSE;
+
+ while ((length--) && ((c = *trace++) != '\0'))
+ {+ if (!isalnum(c))
+ return FICL_FALSE;
+
+ digit = c - '0';
+
+ if (digit > 9)
+ digit = tolower(c) - 'a' + 10;
+
+ if (digit >= base)
+ return FICL_FALSE;
+
+ accumulator = accumulator * base + digit;
+ }
+
+ if (isDouble) /* simple (required) DOUBLE support */
+ ficlStackPushInteger(vm->dataStack, 0);
+
+ if (isNegative)
+ accumulator = -accumulator;
+
+ ficlStackPushInteger(vm->dataStack, accumulator);
+ if (vm->state == FICL_VM_STATE_COMPILE)
+ ficlPrimitiveLiteralIm(vm);
+
+ return FICL_TRUE;
+}
+
+
+
+
+
+/**************************************************************************
+ d i c t C h e c k
+** Checks the dictionary for corruption and throws appropriate
+** errors.
+** Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
+** -n number of ADDRESS UNITS proposed to de-allot
+** 0 just do a consistency check
+**************************************************************************/
+void ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
+#if FICL_ROBUST >= 1
+{+ if ((cells >= 0) && (ficlDictionaryCellsAvailable(dictionary) * (int)sizeof(ficlCell) < cells))
+ {+ ficlVmThrowError(vm, "Error: dictionary full");
+ }
+
+ if ((cells <= 0) && (ficlDictionaryCellsUsed(dictionary) * (int)sizeof(ficlCell) < -cells))
+ {+ ficlVmThrowError(vm, "Error: dictionary underflow");
+ }
+
+ return;
+}
+#else /* FICL_ROBUST >= 1 */
+{+ FICL_IGNORE(vm);
+ FICL_IGNORE(dictionary);
+ FICL_IGNORE(cells);
+}
+#endif /* FICL_ROBUST >= 1 */
+
+
+void ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
+#if FICL_ROBUST >= 1
+{+ ficlVmDictionarySimpleCheck(vm, dictionary, cells);
+
+ if (dictionary->wordlistCount > FICL_MAX_WORDLISTS)
+ {+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmThrowError(vm, "Error: search order overflow");
+ }
+ else if (dictionary->wordlistCount < 0)
+ {+ ficlDictionaryResetSearchOrder(dictionary);
+ ficlVmThrowError(vm, "Error: search order underflow");
+ }
+
+ return;
+}
+#else /* FICL_ROBUST >= 1 */
+{+ FICL_IGNORE(vm);
+ FICL_IGNORE(dictionary);
+ FICL_IGNORE(cells);
+}
+#endif /* FICL_ROBUST >= 1 */
+
+
+
+void ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
+{+ FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
+ FICL_IGNORE(vm);
+ ficlDictionaryAllot(dictionary, n);
+}
+
+
+void ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
+{+ FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
+ FICL_IGNORE(vm);
+ ficlDictionaryAllotCells(dictionary, cells);
+}
+
+
+/**************************************************************************
+ f i c l P a r s e W o r d
+** From the standard, section 3.4
+** b) Search the dictionary name space (see 3.4.2). If a definition name
+** matching the string is found:
+** 1.if interpreting, perform the interpretation semantics of the definition
+** (see 3.4.3.2), and continue at a);
+** 2.if compiling, perform the compilation semantics of the definition
+** (see 3.4.3.3), and continue at a).
+**
+** c) If a definition name matching the string is not found, attempt to
+** convert the string to a number (see 3.4.1.3). If successful:
+** 1.if interpreting, place the number on the data stack, and continue at a);
+** 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place the number on
+** the stack (see 6.1.1780 LITERAL), and continue at a);
+**
+** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
+**
+** (jws 4/01) Modified to be a ficlParseStep
+**************************************************************************/
+int ficlVmParseWord(ficlVm *vm, ficlString name)
+{+ ficlDictionary *dictionary = ficlVmGetDictionary(vm);
+ ficlWord *tempFW;
+
+ FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
+ FICL_STACK_CHECK(vm->dataStack, 0, 0);
+
+#if FICL_WANT_LOCALS
+ if (vm->callback.system->localsCount > 0)
+ {+ tempFW = ficlSystemLookupLocal(vm->callback.system, name);
+ }
+ else
+#endif
+ tempFW = ficlDictionaryLookup(dictionary, name);
+
+ if (vm->state == FICL_VM_STATE_INTERPRET)
+ {+ if (tempFW != NULL)
+ {+ if (ficlWordIsCompileOnly(tempFW))
+ {+ ficlVmThrowError(vm, "Error: FICL_VM_STATE_COMPILE only!");
+ }
+
+ ficlVmExecuteWord(vm, tempFW);
+ return FICL_TRUE;
+ }
+ }
+
+ else /* (vm->state == FICL_VM_STATE_COMPILE) */
+ {+ if (tempFW != NULL)
+ {+ if (ficlWordIsImmediate(tempFW))
+ {+ ficlVmExecuteWord(vm, tempFW);
+ }
+ else
+ {+ if (tempFW->flags & FICL_WORD_INSTRUCTION)
+ ficlDictionaryAppendUnsigned(dictionary, (ficlInteger)tempFW->code);
+ else
+ ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(tempFW));
+ }
+ return FICL_TRUE;
+ }
+ }
+
+ return FICL_FALSE;
+}
+
+
--- a/win32.c
+++ /dev/null
@@ -1,406 +1,0 @@
-/*
- * win32.c
- * submitted to Ficl by Larry Hastings, larry@hastings.org
- * Additional Win32 words by Guy Carver
- *
- * adds calling arbitrary DLL function calls from inside Ficl.
- *
- * note that Microsoft's own header files won't compile without
- * "language extensions" (anonymous structs/unions) turned on.
- * and even with that, it still gives a warning in rpcasync.h
- * for something that compiles clean in C++. I turned it off.
- *
- */
-#pragma warning(disable : 4115)
-#include <stdio.h>
-#include <windows.h>
-#include <string.h>
-#include <direct.h>
-
-#include "ficl.h"
-
-static void loadLibrary(FICL_VM *pVM) /* ( address length -- hmodule ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)_alloca(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
-
- stackPushINT(pVM->pStack, (int)LoadLibrary(buf));
-}
-
-static void getProcAddress(FICL_VM *pVM) /* ( address length hmodule -- ) */
-{
- HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)_alloca(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
-
- stackPushINT(pVM->pStack, (int)GetProcAddress(hModule, buf));
-}
-
-
-static void freeLibrary(FICL_VM *pVM) /* ( hmodule -- ) */
-{
- HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
- FreeLibrary(hModule);
-}
-
-
-static void uAddrToCString(FICL_VM *pVM) /* ( address length -- c-string ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)malloc(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
- stackPushPtr(pVM->pStack, buf);
- return;
-}
-
-
-static void callNativeFunction(FICL_VM *pVM) /* ( ... argcount fnaddress popstack -- returnvalue ) */
-{
- int popstack = stackPopINT(pVM->pStack);
- int fnaddress = stackPopINT(pVM->pStack);
- int argcount = stackPopINT(pVM->pStack);
- int returnvalue;
-
- int i;
- for (i = 0; i < argcount; i++)
- {
- int nextarg = stackPopINT(pVM->pStack);
- __asm
- {
- mov eax, nextarg
- push eax
- }
- }
-
-
- __asm
- {
- call fnaddress
- mov returnvalue, eax
- }
-
- /*
- * if popstack is nonzero,
- * the arguments are popped off the stack after calling
- */
- if (popstack)
- {
- argcount *= 4;
- __asm add esp, argcount
- }
- stackPushINT(pVM->pStack, returnvalue);
- return;
-}
-
-
-/**************************************************************************
- v c a l l
-** Call a class method. (Contributed by Guy Carver)
-** FORTH: (params inst paramcnt vtableindex -- res )
-** INFO: paramcnt has msb set if return value is desired.
-**************************************************************************/
-static void VCall(FICL_VM *pVM)
-{
- int ind,p,paramCnt;
- void *instance;
- int I;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,1);
-#endif
-
- ind = POPINT() * 4;
- paramCnt = POPINT();
- instance = POPPTR(); //Get instance of class.
-
- __asm push ecx //Save ecx.
- __asm push esp //Save stack.
-
- I = paramCnt & 0xFF; //Strip off any flags.
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,I,0);
-#endif
-
- while(I--) //Loop for parameter count.
- {
- p = POPINT();
- __asm
- {
- mov eax,p
- push eax //Push on stack.
- }
- }
- __asm
- {
- mov ecx,instance //Set ecx to instance.
- mov eax,[ecx] //Get method pointer.
- add eax,ind
- call [eax] //Call method.
- mov p,eax //Put result in p.
- pop esp
- pop ecx //Restore ecx and esp.
- }
- if (paramCnt & 0x80000000) //If supposed to return a result.
- PUSHINT(p); //Store result.
-}
-
-
-#if 0
-//**************************************************************
-//Load forth file.
-//ENTER: pVM = Pointer to forth virtual machine.
-//FORTH: ( -<FileName>- )
-//**************************************************************
-static void ForthLoad(FICL_VM *pVM)
-{
- char cp[256];
- char fileName[256];
- FILE *fp;
- int result = 0;
- CELL id;
- int nLine = 0;
- FICL_STRING *pFileName = (FICL_STRING *)fileName;
-
- vmGetString(pVM,pFileName, ' ');
-
- if (pFileName->count <= 0)
- {
- vmTextOut(pVM,"Type fload filename", 1);
- return;
- }
-
- fp = fopen(pFileName->text, "r");
- if (fp)
- {
- id = pVM->sourceID;
- pVM->sourceID.p = (void *)fp; //Set input source id.
-
- while (fgets(cp,256,fp)) //Read line.
- {
- int len = strlen(cp) - 1; //Get length.
-
- nLine++; //Inc line count.
- if (len > 0) //if length.
- {
- cp[len] = 0; //Make sure null terminated.
- result = ficlExec(pVM,cp); //Execute line.
- if ((result == VM_ERREXIT) //If exit.
- || (result == VM_USEREXIT)
- || (result == VM_QUIT))
- {
- pVM->sourceID = id;
- fclose(fp);
- vmThrowErr(pVM, "Error loading file <%s> line %d", pFileName->text, nLine);
- break;
- }
- }
- }
- pVM->sourceID.i = -1;
- ficlExec(pVM,""); //Empty line to flush any pending refills.
- pVM->sourceID = id; //Reset source ID.
- fclose(fp);
- if (result == VM_USEREXIT) //If user exit.
- vmThrow(pVM,VM_USEREXIT); //Resend user exit code.
- }
- else
- {
- vmTextOut(pVM,"Unable to open file: ", 0);
- vmTextOut(pVM, pFileName->text,1);
- }
-}
-
-//********************************************************************************
-//
-//********************************************************************************
-static STRINGINFO parseFileName(FICL_VM *pVM)
-{
- STRINGINFO si;
- char *pSrc = vmGetInBuf(pVM);
- si.cp = pSrc; /* mark start of text */
- while ((*pSrc != ' ') && (*pSrc != 0) && (*pSrc != '\n'))
- {
- if (*(pSrc++) == '\\') /* find next delimiter or end */
- si.cp = pSrc;
- }
- si.count = pSrc - si.cp; /* set length of result */
- return(si);
-}
-
-//********************************************************************************
-//check for included file and load if not loaded.
-//********************************************************************************
-static void include(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code;
-
- si = parseFileName(pVM);
-
- if (si.count)
- {
- pFW = dictLookup(dp, si);
- if (!pFW) //Forget word.
- {
- dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- ForthLoad(pVM);
- }
- }
-}
-
-//********************************************************************************
-//check for included file and kill it if its included to reload.
-//********************************************************************************
-static void reinclude(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW;
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code;
-
- si = parseFileName(pVM);
-
- if (si.count)
- {
- pFW = dictLookup(dp, si);
- if (pFW) //Forget word.
- {
- hashForget(dp->pCompile,pFW->name);
- dp->here = PTRtoCELL (pFW->name);
- }
-
- dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- ForthLoad(pVM);
- }
-}
-
-#endif /* 0 */
-
-
-static void ficlWordGetTickCount(FICL_VM *pVM) /* ( -- ms ) */
-{
- stackPushINT(pVM->pStack, (int)GetTickCount());
-}
-
-
-static void ficlDebugBreak(FICL_VM *pVM) /* ( -- ) */
-{
- DebugBreak();
- pVM = pVM;
-}
-
-
-static void ficlOutputDebugString(FICL_VM *pVM) /* ( c-addr u -- ) */
-{
- int length = stackPopINT(pVM->pStack);
- void *address = (void *)stackPopPtr(pVM->pStack);
-
- char *buf = (char *)_alloca(length + 1);
- memcpy(buf, address, length);
- buf[length] = 0;
-
- OutputDebugString(buf);
-}
-
-
-
-/**************************************************************************
- f i c l C o m p i l e P l a t f o r m
-** Build Win32 platform extensions into the system dictionary
-**************************************************************************/
-void ficlCompilePlatform(FICL_SYSTEM *pSys)
-{
- FICL_DICT *dp = pSys->dp;
- assert (dp);
-
- dictAppendWord(dp, "loadlibrary", loadLibrary, FW_DEFAULT);
- dictAppendWord(dp, "getprocaddress", getProcAddress, FW_DEFAULT);
- dictAppendWord(dp, "freelibrary", freeLibrary, FW_DEFAULT);
- dictAppendWord(dp, "uaddr->cstring", uAddrToCString, FW_DEFAULT);
- dictAppendWord(dp, "callnativefunction",
- callNativeFunction,
- FW_DEFAULT);
- dictAppendWord(dp, "vcall", VCall, FW_DEFAULT);
-/*
- dictAppendWord(dp, "include", include, FW_DEFAULT);
- dictAppendWord(dp, "reinclude", reinclude, FW_DEFAULT);
-*/
- dictAppendWord(dp, "GetTickCount", ficlWordGetTickCount, FW_DEFAULT);
-
- dictAppendWord(dp, "debug-break", ficlDebugBreak, FW_DEFAULT);
- dictAppendWord(dp, "output-debug-string", ficlOutputDebugString, FW_DEFAULT);
-
- return;
-}
-
-
-
-
-/*
-**
-** Heavy, undocumented wizardry here.
-**
-** In Win32, like most OSes, the buffered file I/O functions in the
-** C API (functions that take a FILE * like fopen()) are implemented
-** on top of the raw file I/O functions (functions that take an int,
-** like open()). However, in Win32, these functions in turn are
-** implemented on top of the Win32 native file I/O functions (functions
-** that take a HANDLE, like CreateFile()). This behavior is undocumented
-** but easy to deduce by reading the CRT/SRC directory.
-**
-** The below mishmash of typedefs and defines were copied from
-** CRT/SRC/INTERNAL.H.
-**
-** --lch
-*/
-typedef struct {
- long osfhnd; /* underlying OS file HANDLE */
- char osfile; /* attributes of file (e.g., open in text mode?) */
- char pipech; /* one char buffer for handles opened on pipes */
-#ifdef _MT
- int lockinitflag;
- CRITICAL_SECTION lock;
-#endif /* _MT */
- } ioinfo;
-extern _CRTIMP ioinfo * __pioinfo[];
-
-#define IOINFO_L2E 5
-#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
-#define _pioinfo(i) ( __pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - \
- 1)) )
-#define _osfhnd(i) ( _pioinfo(i)->osfhnd )
-
-
-int ftruncate(int fileno, size_t size)
-{
- HANDLE hFile = (HANDLE)_osfhnd(fileno);
- if (SetFilePointer(hFile, size, NULL, FILE_BEGIN) != size)
- return 0;
- return !SetEndOfFile(hFile);
-}
-
-#if 0
-unsigned long ficlNtohl(unsigned long number)
-{
- return ntohl(number);
-}
-#endif
-
-
-
-
--- a/words.c
+++ /dev/null
@@ -1,4939 +1,0 @@
-/*******************************************************************
-** w o r d s . c
-** Forth Inspired Command Language
-** ANS Forth CORE word-set written in C
-** Author: John Sadler (john_sadler@alum.mit.edu)
-** Created: 19 July 1997
-** $Id: words.c,v 1.17 2001/12/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.
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <ctype.h>
-#include "ficl.h"
-#include "math64.h"
-
-static void colonParen(FICL_VM *pVM);
-static void literalIm(FICL_VM *pVM);
-static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
-
-/*
-** Control structure building words use these
-** strings' addresses as markers on the stack to
-** check for structure completion.
-*/
-static char doTag[] = "do";
-static char colonTag[] = "colon";
-static char leaveTag[] = "leave";
-
-static char destTag[] = "target";
-static char origTag[] = "origin";
-
-#if FICL_WANT_LOCALS
-static void doLocalIm(FICL_VM *pVM);
-static void do2LocalIm(FICL_VM *pVM);
-#endif
-
-
-/*
-** C O N T R O L S T R U C T U R E B U I L D E R S
-**
-** Push current dict location for later branch resolution.
-** The location may be either a branch target or a patch address...
-*/
-static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- PUSHPTR(dp->here);
- PUSHPTR(tag);
- return;
-}
-
-static void markControlTag(FICL_VM *pVM, char *tag)
-{
- PUSHPTR(tag);
- return;
-}
-
-static void matchControlTag(FICL_VM *pVM, char *tag)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- cp = (char *)stackPopPtr(pVM->pStack);
- /*
- ** Changed the code below to compare the pointers first (by popular demand)
- */
- if ( (cp != tag) && strcmp(cp, tag) )
- {
- vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
- }
-
- return;
-}
-
-/*
-** Expect a branch target address on the param stack,
-** compile a literal offset from the current dict location
-** to the target address
-*/
-static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- FICL_INT offset;
- CELL *patchAddr;
-
- matchControlTag(pVM, tag);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- offset = patchAddr - dp->here;
- dictAppendCell(dp, LVALUEtoCELL(offset));
-
- return;
-}
-
-
-/*
-** Expect a branch patch address on the param stack,
-** compile a literal offset from the patch location
-** to the current dict location
-*/
-static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- FICL_INT offset;
- CELL *patchAddr;
-
- matchControlTag(pVM, tag);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- offset = dp->here - patchAddr;
- *patchAddr = LVALUEtoCELL(offset);
-
- return;
-}
-
-/*
-** Match the tag to the top of the stack. If success,
-** sopy "here" address into the cell whose address is next
-** on the stack. Used by do..leave..loop.
-*/
-static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
-{
- CELL *patchAddr;
- char *cp;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- cp = stackPopPtr(pVM->pStack);
- /*
- ** Changed the comparison below to compare the pointers first (by popular demand)
- */
- if ((cp != tag) && strcmp(cp, tag))
- {
- vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
- vmTextOut(pVM, tag, 1);
- }
-
- patchAddr = (CELL *)stackPopPtr(pVM->pStack);
- *patchAddr = LVALUEtoCELL(dp->here);
-
- return;
-}
-
-
-/**************************************************************************
- f i c l P a r s e N u m b e r
-** Attempts to convert the NULL terminated string in the VM's pad to
-** a number using the VM's current base. If successful, pushes the number
-** onto the param stack and returns TRUE. Otherwise, returns FALSE.
-** (jws 8/01) Trailing decimal point causes a zero cell to be pushed. (See
-** the standard for DOUBLE wordset.
-**************************************************************************/
-
-int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
-{
- FICL_INT accum = 0;
- char isNeg = FALSE;
- char hasDP = FALSE;
- unsigned base = pVM->base;
- char *cp = SI_PTR(si);
- FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
- unsigned ch;
- unsigned digit;
-
- if (count > 1)
- {
- switch (*cp)
- {
- case '-':
- cp++;
- count--;
- isNeg = TRUE;
- break;
- case '+':
- cp++;
- count--;
- isNeg = FALSE;
- break;
- default:
- break;
- }
- }
-
- if ((count > 0) && (cp[count-1] == '.')) /* detect & remove trailing decimal */
- {
- hasDP = TRUE;
- count--;
- }
-
- if (count == 0) /* detect "+", "-", ".", "+." etc */
- return FALSE;
-
- while ((count--) && ((ch = *cp++) != '\0'))
- {
- if (!isalnum(ch))
- return FALSE;
-
- digit = ch - '0';
-
- if (digit > 9)
- digit = tolower(ch) - 'a' + 10;
-
- if (digit >= base)
- return FALSE;
-
- accum = accum * base + digit;
- }
-
- if (hasDP) /* simple (required) DOUBLE support */
- PUSHINT(0);
-
- if (isNeg)
- accum = -accum;
-
- PUSHINT(accum);
- if (pVM->state == COMPILE)
- literalIm(pVM);
-
- return TRUE;
-}
-
-
-/**************************************************************************
- a d d & f r i e n d s
-**
-**************************************************************************/
-
-static void add(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i += stackGetTop(pVM->pStack).i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void sub(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i = stackGetTop(pVM->pStack).i - i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void mul(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i *= stackGetTop(pVM->pStack).i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void negate(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = -stackPopINT(pVM->pStack);
- PUSHINT(i);
- return;
-}
-
-static void ficlDiv(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- i = stackPopINT(pVM->pStack);
- i = stackGetTop(pVM->pStack).i / i;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-/*
-** slash-mod CORE ( n1 n2 -- n3 n4 )
-** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
-** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
-** differ in sign, the implementation-defined result returned will be the
-** same as that returned by either the phrase
-** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
-** NOTE: Ficl complies with the second phrase (symmetric division)
-*/
-static void slashMod(FICL_VM *pVM)
-{
- DPINT n1;
- FICL_INT n2;
- INTQR qr;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
- n2 = stackPopINT(pVM->pStack);
- n1.lo = stackPopINT(pVM->pStack);
- i64Extend(n1);
-
- qr = m64SymmetricDivI(n1, n2);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-static void onePlus(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i += 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void oneMinus(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i -= 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void twoMul(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i *= 2;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void twoDiv(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- i = stackGetTop(pVM->pStack).i;
- i >>= 1;
- stackSetTop(pVM->pStack, LVALUEtoCELL(i));
- return;
-}
-
-static void mulDiv(FICL_VM *pVM)
-{
- FICL_INT x, y, z;
- DPINT prod;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 1);
-#endif
- z = stackPopINT(pVM->pStack);
- y = stackPopINT(pVM->pStack);
- x = stackPopINT(pVM->pStack);
-
- prod = m64MulI(x,y);
- x = m64SymmetricDivI(prod, z).quot;
-
- PUSHINT(x);
- return;
-}
-
-
-static void mulDivRem(FICL_VM *pVM)
-{
- FICL_INT x, y, z;
- DPINT prod;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 2);
-#endif
- z = stackPopINT(pVM->pStack);
- y = stackPopINT(pVM->pStack);
- x = stackPopINT(pVM->pStack);
-
- prod = m64MulI(x,y);
- qr = m64SymmetricDivI(prod, z);
-
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- c o l o n d e f i n i t i o n s
-** Code to begin compiling a colon definition
-** This function sets the state to COMPILE, then creates a
-** new word whose name is the next word in the input stream
-** and whose code is colonParen.
-**************************************************************************/
-
-static void colon(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- pVM->state = COMPILE;
- markControlTag(pVM, colonTag);
- dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
-#if FICL_WANT_LOCALS
- pVM->pSys->nLocals = 0;
-#endif
- return;
-}
-
-
-/**************************************************************************
- c o l o n P a r e n
-** This is the code that executes a colon definition. It assumes that the
-** virtual machine is running a "next" loop (See the vm.c
-** for its implementation of member function vmExecute()). The colon
-** code simply copies the address of the first word in the list of words
-** to interpret into IP after saving its old value. When we return to the
-** "next" loop, the virtual machine will call the code for each word in
-** turn.
-**
-**************************************************************************/
-
-static void colonParen(FICL_VM *pVM)
-{
- IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
- vmPushIP(pVM, tempIP);
-
- return;
-}
-
-
-/**************************************************************************
- s e m i c o l o n C o I m
-**
-** IMMEDIATE code for ";". This function sets the state to INTERPRET and
-** terminates a word under compilation by appending code for "(;)" to
-** the definition. TO DO: checks for leftover branch target tags on the
-** return stack and complains if any are found.
-**************************************************************************/
-static void semiParen(FICL_VM *pVM)
-{
- vmPopIP(pVM);
- return;
-}
-
-
-static void semicolonCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pSemiParen);
- matchControlTag(pVM, colonTag);
-
-#if FICL_WANT_LOCALS
- assert(pVM->pSys->pUnLinkParen);
- if (pVM->pSys->nLocals > 0)
- {
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
- pVM->pSys->nLocals = 0;
-#endif
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pSemiParen));
- pVM->state = INTERPRET;
- dictUnsmudge(dp);
- return;
-}
-
-
-/**************************************************************************
- e x i t
-** CORE
-** This function simply pops the previous instruction
-** pointer and returns to the "next" loop. Used for exiting from within
-** a definition. Note that exitParen is identical to semiParen - they
-** are in two different functions so that "see" can correctly identify
-** the end of a colon definition, even if it uses "exit".
-**************************************************************************/
-static void exitParen(FICL_VM *pVM)
-{
- vmPopIP(pVM);
- return;
-}
-
-static void exitCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pExitParen);
- IGNORE(pVM);
-
-#if FICL_WANT_LOCALS
- if (pVM->pSys->nLocals > 0)
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
-#endif
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pExitParen));
- return;
-}
-
-
-/**************************************************************************
- c o n s t a n t P a r e n
-** This is the run-time code for "constant". It simply returns the
-** contents of its word's first data cell.
-**
-**************************************************************************/
-
-void constantParen(FICL_VM *pVM)
-{
- FICL_WORD *pFW = pVM->runningWord;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- stackPush(pVM->pStack, pFW->param[0]);
- return;
-}
-
-void twoConstParen(FICL_VM *pVM)
-{
- FICL_WORD *pFW = pVM->runningWord;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, pFW->param[0]); /* lo */
- stackPush(pVM->pStack, pFW->param[1]); /* hi */
- return;
-}
-
-
-/**************************************************************************
- c o n s t a n t
-** IMMEDIATE
-** Compiles a constant into the dictionary. Constants return their
-** value when invoked. Expects a value on top of the parm stack.
-**************************************************************************/
-
-static void constant(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
- dictAppendCell(dp, stackPop(pVM->pStack));
- return;
-}
-
-
-static void twoConstant(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
- CELL c;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- c = stackPop(pVM->pStack);
- dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
- dictAppendCell(dp, stackPop(pVM->pStack));
- dictAppendCell(dp, c);
- return;
-}
-
-
-/**************************************************************************
- d i s p l a y C e l l
-** Drop and print the contents of the cell at the top of the param
-** stack
-**************************************************************************/
-
-static void displayCell(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- c = stackPop(pVM->pStack);
- ltoa((c).i, pVM->pad, pVM->base);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-static void uDot(FICL_VM *pVM)
-{
- FICL_UNS u;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- u = stackPopUNS(pVM->pStack);
- ultoa(u, pVM->pad, pVM->base);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-
-static void hexDot(FICL_VM *pVM)
-{
- FICL_UNS u;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- u = stackPopUNS(pVM->pStack);
- ultoa(u, pVM->pad, 16);
- strcat(pVM->pad, " ");
- vmTextOut(pVM, pVM->pad, 0);
- return;
-}
-
-
-/**************************************************************************
- s t r l e n
-** FICL ( c-string -- length )
-**
-** Returns the length of a C-style (zero-terminated) string.
-**
-** --lch
-**/
-static void ficlStrlen(FICL_VM *ficlVM)
- {
- char *address = (char *)stackPopPtr(ficlVM->pStack);
- stackPushINT(ficlVM->pStack, strlen(address));
- }
-
-
-/**************************************************************************
- s p r i n t f
-** FICL ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- c-addr-buffer u-written success-flag )
-** Similar to the C sprintf() function. It formats into a buffer based on
-** a "format" string. Each character in the format string is copied verbatim
-** to the output buffer, until SPRINTF encounters a percent sign ("%").
-** SPRINTF then skips the percent sign, and examines the next character
-** (the "format character"). Here are the valid format characters:
-** s - read a C-ADDR U-LENGTH string from the stack and copy it to
-** the buffer
-** d - read a cell from the stack, format it as a string (base-10,
-** signed), and copy it to the buffer
-** x - same as d, except in base-16
-** u - same as d, but unsigned
-** % - output a literal percent-sign to the buffer
-** SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes
-** written, and a flag indicating whether or not it ran out of space while
-** writing to the output buffer (TRUE if it ran out of space).
-**
-** If SPRINTF runs out of space in the buffer to store the formatted string,
-** it still continues parsing, in an effort to preserve your stack (otherwise
-** it might leave uneaten arguments behind).
-**
-** --lch
-**************************************************************************/
-static void ficlSprintf(FICL_VM *pVM) /* */
-{
- int bufferLength = stackPopINT(pVM->pStack);
- char *buffer = (char *)stackPopPtr(pVM->pStack);
- char *bufferStart = buffer;
-
- int formatLength = stackPopINT(pVM->pStack);
- char *format = (char *)stackPopPtr(pVM->pStack);
- char *formatStop = format + formatLength;
-
- int base = 10;
- int unsignedInteger = FALSE;
-
- int append = FICL_TRUE;
-
- while (format < formatStop)
- {
- char scratch[64];
- char *source;
- int actualLength;
- int desiredLength;
- int leadingZeroes;
-
-
- if (*format != '%')
- {
- source = format;
- actualLength = desiredLength = 1;
- leadingZeroes = 0;
- }
- else
- {
- format++;
- if (format == formatStop)
- break;
-
- leadingZeroes = (*format == '0');
- if (leadingZeroes)
- {
- format++;
- if (format == formatStop)
- break;
- }
-
- desiredLength = isdigit(*format);
- if (desiredLength)
- {
- desiredLength = strtoul(format, &format, 10);
- if (format == formatStop)
- break;
- }
- else if (*format == '*')
- {
- desiredLength = stackPopINT(pVM->pStack);
- format++;
- if (format == formatStop)
- break;
- }
-
-
- switch (*format)
- {
- case 's':
- case 'S':
- {
- actualLength = stackPopINT(pVM->pStack);
- source = (char *)stackPopPtr(pVM->pStack);
- break;
- }
- case 'x':
- case 'X':
- base = 16;
- case 'u':
- case 'U':
- unsignedInteger = TRUE;
- case 'd':
- case 'D':
- {
- int integer = stackPopINT(pVM->pStack);
- if (unsignedInteger)
- ultoa(integer, scratch, base);
- else
- ltoa(integer, scratch, base);
- base = 10;
- unsignedInteger = FALSE;
- source = scratch;
- actualLength = strlen(scratch);
- break;
- }
- case '%':
- source = format;
- actualLength = 1;
- default:
- continue;
- }
- }
-
- if (append == FICL_TRUE)
- {
- if (!desiredLength)
- desiredLength = actualLength;
- if (desiredLength > bufferLength)
- {
- append = FICL_FALSE;
- desiredLength = bufferLength;
- }
- while (desiredLength > actualLength)
- {
- *buffer++ = (char)((leadingZeroes) ? '0' : ' ');
- bufferLength--;
- desiredLength--;
- }
- memcpy(buffer, source, actualLength);
- buffer += actualLength;
- bufferLength -= actualLength;
- }
-
- format++;
- }
-
- stackPushPtr(pVM->pStack, bufferStart);
- stackPushINT(pVM->pStack, buffer - bufferStart);
- stackPushINT(pVM->pStack, append);
-}
-
-
-/**************************************************************************
- d u p & f r i e n d s
-**
-**************************************************************************/
-
-static void depth(FICL_VM *pVM)
-{
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- i = stackDepth(pVM->pStack);
- PUSHINT(i);
- return;
-}
-
-
-static void drop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- stackDrop(pVM->pStack, 1);
- return;
-}
-
-
-static void twoDrop(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- stackDrop(pVM->pStack, 2);
- return;
-}
-
-
-static void dup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- stackPick(pVM->pStack, 0);
- return;
-}
-
-
-static void twoDup(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 4);
-#endif
- stackPick(pVM->pStack, 1);
- stackPick(pVM->pStack, 1);
- return;
-}
-
-
-static void over(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 3);
-#endif
- stackPick(pVM->pStack, 1);
- return;
-}
-
-static void twoOver(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 4, 6);
-#endif
- stackPick(pVM->pStack, 3);
- stackPick(pVM->pStack, 3);
- return;
-}
-
-
-static void pick(FICL_VM *pVM)
-{
- CELL c = stackPop(pVM->pStack);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, c.i+1, c.i+2);
-#endif
- stackPick(pVM->pStack, c.i);
- return;
-}
-
-
-static void questionDup(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- c = stackGetTop(pVM->pStack);
-
- if (c.i != 0)
- stackPick(pVM->pStack, 0);
-
- return;
-}
-
-
-static void roll(FICL_VM *pVM)
-{
- int i = stackPop(pVM->pStack).i;
- i = (i > 0) ? i : 0;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, i+1, i+1);
-#endif
- stackRoll(pVM->pStack, i);
- return;
-}
-
-
-static void minusRoll(FICL_VM *pVM)
-{
- int i = stackPop(pVM->pStack).i;
- i = (i > 0) ? i : 0;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, i+1, i+1);
-#endif
- stackRoll(pVM->pStack, -i);
- return;
-}
-
-
-static void rot(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 3);
-#endif
- stackRoll(pVM->pStack, 2);
- return;
-}
-
-
-static void swap(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
- stackRoll(pVM->pStack, 1);
- return;
-}
-
-
-static void twoSwap(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 4, 4);
-#endif
- stackRoll(pVM->pStack, 3);
- stackRoll(pVM->pStack, 3);
- return;
-}
-
-
-/**************************************************************************
- e m i t & f r i e n d s
-**
-**************************************************************************/
-
-static void emit(FICL_VM *pVM)
-{
- char *cp = pVM->pad;
- int i;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- i = stackPopINT(pVM->pStack);
- cp[0] = (char)i;
- cp[1] = '\0';
- vmTextOut(pVM, cp, 0);
- return;
-}
-
-
-static void cr(FICL_VM *pVM)
-{
- vmTextOut(pVM, "", 1);
- return;
-}
-
-
-static void commentLine(FICL_VM *pVM)
-{
- char *cp = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- char ch = *cp;
-
- while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
- {
- ch = *++cp;
- }
-
- /*
- ** Cope with DOS or UNIX-style EOLs -
- ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
- ** and point cp to next char. If EOL is \0, we're done.
- */
- if (cp != pEnd)
- {
- cp++;
-
- if ( (cp != pEnd) && (ch != *cp)
- && ((*cp == '\r') || (*cp == '\n')) )
- cp++;
- }
-
- vmUpdateTib(pVM, cp);
- return;
-}
-
-
-/*
-** paren CORE
-** Compilation: Perform the execution semantics given below.
-** Execution: ( "ccc<paren>" -- )
-** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
-** The number of characters in ccc may be zero to the number of characters
-** in the parse area.
-**
-*/
-static void commentHang(FICL_VM *pVM)
-{
- vmParseStringEx(pVM, ')', 0);
- return;
-}
-
-
-/**************************************************************************
- F E T C H & S T O R E
-**
-**************************************************************************/
-
-static void fetch(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- stackPush(pVM->pStack, *pCell);
- return;
-}
-
-/*
-** two-fetch CORE ( a-addr -- x1 x2 )
-** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
-** x1 at the next consecutive cell. It is equivalent to the sequence
-** DUP CELL+ @ SWAP @ .
-*/
-static void twoFetch(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- stackPush(pVM->pStack, *pCell++);
- stackPush(pVM->pStack, *pCell);
- swap(pVM);
- return;
-}
-
-/*
-** store CORE ( x a-addr -- )
-** Store x at a-addr.
-*/
-static void store(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- *pCell = stackPop(pVM->pStack);
-}
-
-/*
-** two-store CORE ( x1 x2 a-addr -- )
-** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
-** next consecutive cell. It is equivalent to the sequence
-** SWAP OVER ! CELL+ ! .
-*/
-static void twoStore(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 3, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- *pCell++ = stackPop(pVM->pStack);
- *pCell = stackPop(pVM->pStack);
-}
-
-static void plusStore(FICL_VM *pVM)
-{
- CELL *pCell;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pCell = (CELL *)stackPopPtr(pVM->pStack);
- pCell->i += stackPop(pVM->pStack).i;
-}
-
-
-static void quadFetch(FICL_VM *pVM)
-{
- UNS32 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pw = (UNS32 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pw);
- return;
-}
-
-static void quadStore(FICL_VM *pVM)
-{
- UNS32 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pw = (UNS32 *)stackPopPtr(pVM->pStack);
- *pw = (UNS32)(stackPop(pVM->pStack).u);
-}
-
-static void wFetch(FICL_VM *pVM)
-{
- UNS16 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pw = (UNS16 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pw);
- return;
-}
-
-static void wStore(FICL_VM *pVM)
-{
- UNS16 *pw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pw = (UNS16 *)stackPopPtr(pVM->pStack);
- *pw = (UNS16)(stackPop(pVM->pStack).u);
-}
-
-static void cFetch(FICL_VM *pVM)
-{
- UNS8 *pc;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- pc = (UNS8 *)stackPopPtr(pVM->pStack);
- PUSHUNS((FICL_UNS)*pc);
- return;
-}
-
-static void cStore(FICL_VM *pVM)
-{
- UNS8 *pc;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- pc = (UNS8 *)stackPopPtr(pVM->pStack);
- *pc = (UNS8)(stackPop(pVM->pStack).u);
-}
-
-
-/**************************************************************************
- i f C o I m
-** IMMEDIATE
-** Compiles code for a conditional branch into the dictionary
-** and pushes the branch patch address on the stack for later
-** patching by ELSE or THEN/ENDIF.
-**************************************************************************/
-
-static void ifCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pIfParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
- markBranch(dp, pVM, origTag);
- dictAppendUNS(dp, 1);
- return;
-}
-
-
-/**************************************************************************
- i f P a r e n
-** Runtime code to do "if" or "until": pop a flag from the stack,
-** fall through if true, branch if false. Probably ought to be
-** called (not?branch) since it does "branch if false".
-**************************************************************************/
-
-static void ifParen(FICL_VM *pVM)
-{
- FICL_UNS flag;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- flag = stackPopUNS(pVM->pStack);
-
- if (flag)
- { /* fall through */
- vmBranchRelative(pVM, 1);
- }
- else
- { /* take branch (to else/endif/begin) */
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-/**************************************************************************
- e l s e C o I m
-**
-** IMMEDIATE -- compiles an "else"...
-** 1) Compile a branch and a patch address; the address gets patched
-** by "endif" to point past the "else" code.
-** 2) Pop the the "if" patch address
-** 3) Patch the "if" branch to point to the current compile address.
-** 4) Push the "else" patch address. ("endif" patches this to jump past
-** the "else" code.
-**************************************************************************/
-
-static void elseCoIm(FICL_VM *pVM)
-{
- CELL *patchAddr;
- FICL_INT offset;
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- /* (1) compile branch runtime */
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
- matchControlTag(pVM, origTag);
- patchAddr =
- (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */
- markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */
- dictAppendUNS(dp, 1); /* (1) compile patch placeholder */
- offset = dp->here - patchAddr;
- *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */
-
- return;
-}
-
-
-/**************************************************************************
- b r a n c h P a r e n
-**
-** Runtime for "(branch)" -- expects a literal offset in the next
-** compilation address, and branches to that location.
-**************************************************************************/
-
-static void branchParen(FICL_VM *pVM)
-{
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- return;
-}
-
-
-/**************************************************************************
- e n d i f C o I m
-**
-**************************************************************************/
-
-static void endifCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- resolveForwardBranch(dp, pVM, origTag);
- return;
-}
-
-
-/**************************************************************************
- h a s h
-** hash ( c-addr u -- code)
-** calculates hashcode of specified string and leaves it on the stack
-**************************************************************************/
-
-static void hash(FICL_VM *pVM)
-{
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- PUSHUNS(hashHashCode(si));
- return;
-}
-
-
-/**************************************************************************
- i n t e r p r e t
-** This is the "user interface" of a Forth. It does the following:
-** while there are words in the VM's Text Input Buffer
-** Copy next word into the pad (vmGetWord)
-** Attempt to find the word in the dictionary (dictLookup)
-** If successful, execute the word.
-** Otherwise, attempt to convert the word to a number (isNumber)
-** If successful, push the number onto the parameter stack.
-** Otherwise, print an error message and exit loop...
-** End Loop
-**
-** From the standard, section 3.4
-** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
-** repeat the following steps until either the parse area is empty or an
-** ambiguous condition exists:
-** a) Skip leading spaces and parse a name (see 3.4.1);
-**************************************************************************/
-
-static void interpret(FICL_VM *pVM)
-{
- STRINGINFO si;
- int i;
- FICL_SYSTEM *pSys;
-
- assert(pVM);
-
- pSys = pVM->pSys;
- si = vmGetWord0(pVM);
-
- /*
- ** Get next word...if out of text, we're done.
- */
- if (si.count == 0)
- {
- vmThrow(pVM, VM_OUTOFTEXT);
- }
-
- /*
- ** Attempt to find the incoming token in the dictionary. If that fails...
- ** run the parse chain against the incoming token until somebody eats it.
- ** Otherwise emit an error message and give up.
- ** Although ficlParseWord could be part of the parse list, I've hard coded it
- ** in for robustness. ficlInitSystem adds the other default steps to the list.
- */
- if (ficlParseWord(pVM, si))
- return;
-
- for (i=0; i < FICL_MAX_PARSE_STEPS; i++)
- {
- FICL_WORD *pFW = pSys->parseList[i];
-
- if (pFW == NULL)
- break;
-
- if (pFW->code == parseStepParen)
- {
- FICL_PARSE_STEP pStep;
- pStep = (FICL_PARSE_STEP)(pFW->param->fn);
- if ((*pStep)(pVM, si))
- return;
- }
- else
- {
- stackPushPtr(pVM->pStack, SI_PTR(si));
- stackPushUNS(pVM->pStack, SI_COUNT(si));
- ficlExecXT(pVM, pFW);
- if (stackPopINT(pVM->pStack))
- return;
- }
- }
-
- i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
-
- return; /* back to inner interpreter */
-}
-
-
-/**************************************************************************
- f i c l P a r s e W o r d
-** From the standard, section 3.4
-** b) Search the dictionary name space (see 3.4.2). If a definition name
-** matching the string is found:
-** 1.if interpreting, perform the interpretation semantics of the definition
-** (see 3.4.3.2), and continue at a);
-** 2.if compiling, perform the compilation semantics of the definition
-** (see 3.4.3.3), and continue at a).
-**
-** c) If a definition name matching the string is not found, attempt to
-** convert the string to a number (see 3.4.1.3). If successful:
-** 1.if interpreting, place the number on the data stack, and continue at a);
-** 2.if compiling, compile code that when executed will place the number on
-** the stack (see 6.1.1780 LITERAL), and continue at a);
-**
-** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
-**
-** (jws 4/01) Modified to be a FICL_PARSE_STEP
-**************************************************************************/
-static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *tempFW;
-
-#if FICL_ROBUST
- dictCheck(dp, pVM, 0);
- vmCheckStack(pVM, 0, 0);
-#endif
-
-#if FICL_WANT_LOCALS
- if (pVM->pSys->nLocals > 0)
- {
- tempFW = ficlLookupLoc(pVM->pSys, si);
- }
- else
-#endif
- tempFW = dictLookup(dp, si);
-
- if (pVM->state == INTERPRET)
- {
- if (tempFW != NULL)
- {
- if (wordIsCompileOnly(tempFW))
- {
- vmThrowErr(pVM, "Error: Compile only!");
- }
-
- vmExecute(pVM, tempFW);
- return FICL_TRUE;
- }
- }
-
- else /* (pVM->state == COMPILE) */
- {
- if (tempFW != NULL)
- {
- if (wordIsImmediate(tempFW))
- {
- vmExecute(pVM, tempFW);
- }
- else
- {
- dictAppendCell(dp, LVALUEtoCELL(tempFW));
- }
- return FICL_TRUE;
- }
- }
-
- return FICL_FALSE;
-}
-
-
-/*
-** Surrogate precompiled parse step for ficlParseWord (this step is hard coded in
-** INTERPRET)
-*/
-static void lookup(FICL_VM *pVM)
-{
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- stackPushINT(pVM->pStack, ficlParseWord(pVM, si));
- return;
-}
-
-
-/**************************************************************************
- p a r e n P a r s e S t e p
-** (parse-step) ( c-addr u -- flag )
-** runtime for a precompiled parse step - pop a counted string off the
-** stack, run the parse step against it, and push the result flag (FICL_TRUE
-** if success, FICL_FALSE otherwise).
-**************************************************************************/
-
-void parseStepParen(FICL_VM *pVM)
-{
- STRINGINFO si;
- FICL_WORD *pFW = pVM->runningWord;
- FICL_PARSE_STEP pStep = (FICL_PARSE_STEP)(pFW->param->fn);
-
- SI_SETLEN(si, stackPopINT(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
-
- PUSHINT((*pStep)(pVM, si));
-
- return;
-}
-
-
-static void addParseStep(FICL_VM *pVM)
-{
- FICL_WORD *pStep;
- FICL_DICT *pd = vmGetDict(pVM);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
- if ((pStep != NULL) && isAFiclWord(pd, pStep))
- ficlAddParseStep(pVM->pSys, pStep);
- return;
-}
-
-
-/**************************************************************************
- l i t e r a l P a r e n
-**
-** This is the runtime for (literal). It assumes that it is part of a colon
-** definition, and that the next CELL contains a value to be pushed on the
-** parameter stack at runtime. This code is compiled by "literal".
-**
-**************************************************************************/
-
-static void literalParen(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- PUSHINT(*(FICL_INT *)(pVM->ip));
- vmBranchRelative(pVM, 1);
- return;
-}
-
-static void twoLitParen(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- PUSHINT(*((FICL_INT *)(pVM->ip)+1));
- PUSHINT(*(FICL_INT *)(pVM->ip));
- vmBranchRelative(pVM, 2);
- return;
-}
-
-
-/**************************************************************************
- l i t e r a l I m
-**
-** IMMEDIATE code for "literal". This function gets a value from the stack
-** and compiles it into the dictionary preceded by the code for "(literal)".
-** IMMEDIATE
-**************************************************************************/
-
-static void literalIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pLitParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLitParen));
- dictAppendCell(dp, stackPop(pVM->pStack));
-
- return;
-}
-
-
-static void twoLiteralIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- assert(pVM->pSys->pTwoLitParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTwoLitParen));
- dictAppendCell(dp, stackPop(pVM->pStack));
- dictAppendCell(dp, stackPop(pVM->pStack));
-
- return;
-}
-
-/**************************************************************************
- l o g i c a n d c o m p a r i s o n s
-**
-**************************************************************************/
-
-static void zeroEquals(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void zeroLess(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void zeroGreater(FICL_VM *pVM)
-{
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
- stackPush(pVM->pStack, c);
- return;
-}
-
-static void isEqual(FICL_VM *pVM)
-{
- CELL x, y;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i == y.i));
- return;
-}
-
-static void isLess(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- y = stackPop(pVM->pStack);
- x = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i < y.i));
- return;
-}
-
-static void uIsLess(FICL_VM *pVM)
-{
- FICL_UNS u1, u2;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- u2 = stackPopUNS(pVM->pStack);
- u1 = stackPopUNS(pVM->pStack);
- PUSHINT(FICL_BOOL(u1 < u2));
- return;
-}
-
-static void isGreater(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- y = stackPop(pVM->pStack);
- x = stackPop(pVM->pStack);
- PUSHINT(FICL_BOOL(x.i > y.i));
- return;
-}
-
-static void bitwiseAnd(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i & y.i);
- return;
-}
-
-static void bitwiseOr(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i | y.i);
- return;
-}
-
-static void bitwiseXor(FICL_VM *pVM)
-{
- CELL x, y;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 1);
-#endif
- x = stackPop(pVM->pStack);
- y = stackPop(pVM->pStack);
- PUSHINT(x.i ^ y.i);
- return;
-}
-
-static void bitwiseNot(FICL_VM *pVM)
-{
- CELL x;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
- x = stackPop(pVM->pStack);
- PUSHINT(~x.i);
- return;
-}
-
-
-/**************************************************************************
- D o / L o o p
-** do -- IMMEDIATE COMPILE ONLY
-** Compiles code to initialize a loop: compile (do),
-** allot space to hold the "leave" address, push a branch
-** target address for the loop.
-** (do) -- runtime for "do"
-** pops index and limit from the p stack and moves them
-** to the r stack, then skips to the loop body.
-** loop -- IMMEDIATE COMPILE ONLY
-** +loop
-** Compiles code for the test part of a loop:
-** compile (loop), resolve forward branch from "do", and
-** copy "here" address to the "leave" address allotted by "do"
-** i,j,k -- COMPILE ONLY
-** Runtime: Push loop indices on param stack (i is innermost loop...)
-** Note: each loop has three values on the return stack:
-** ( R: leave limit index )
-** "leave" is the absolute address of the next cell after the loop
-** limit and index are the loop control variables.
-** leave -- COMPILE ONLY
-** Runtime: pop the loop control variables, then pop the
-** "leave" address and jump (absolute) there.
-**************************************************************************/
-
-static void doCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pDoParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoParen));
- /*
- ** Allot space for a pointer to the end
- ** of the loop - "leave" uses this...
- */
- markBranch(dp, pVM, leaveTag);
- dictAppendUNS(dp, 0);
- /*
- ** Mark location of head of loop...
- */
- markBranch(dp, pVM, doTag);
-
- return;
-}
-
-
-static void doParen(FICL_VM *pVM)
-{
- CELL index, limit;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- index = stackPop(pVM->pStack);
- limit = stackPop(pVM->pStack);
-
- /* copy "leave" target addr to stack */
- stackPushPtr(pVM->rStack, *(pVM->ip++));
- stackPush(pVM->rStack, limit);
- stackPush(pVM->rStack, index);
-
- return;
-}
-
-
-static void qDoCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pQDoParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pQDoParen));
- /*
- ** Allot space for a pointer to the end
- ** of the loop - "leave" uses this...
- */
- markBranch(dp, pVM, leaveTag);
- dictAppendUNS(dp, 0);
- /*
- ** Mark location of head of loop...
- */
- markBranch(dp, pVM, doTag);
-
- return;
-}
-
-
-static void qDoParen(FICL_VM *pVM)
-{
- CELL index, limit;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- index = stackPop(pVM->pStack);
- limit = stackPop(pVM->pStack);
-
- /* copy "leave" target addr to stack */
- stackPushPtr(pVM->rStack, *(pVM->ip++));
-
- if (limit.u == index.u)
- {
- vmPopIP(pVM);
- }
- else
- {
- stackPush(pVM->rStack, limit);
- stackPush(pVM->rStack, index);
- }
-
- return;
-}
-
-
-/*
-** Runtime code to break out of a do..loop construct
-** Drop the loop control variables; the branch address
-** past "loop" is next on the return stack.
-*/
-static void leaveCo(FICL_VM *pVM)
-{
- /* almost unloop */
- stackDrop(pVM->rStack, 2);
- /* exit */
- vmPopIP(pVM);
- return;
-}
-
-
-static void unloopCo(FICL_VM *pVM)
-{
- stackDrop(pVM->rStack, 3);
- return;
-}
-
-
-static void loopCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pLoopParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pLoopParen));
- resolveBackBranch(dp, pVM, doTag);
- resolveAbsBranch(dp, pVM, leaveTag);
- return;
-}
-
-
-static void plusLoopCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pPLoopParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pPLoopParen));
- resolveBackBranch(dp, pVM, doTag);
- resolveAbsBranch(dp, pVM, leaveTag);
- return;
-}
-
-
-static void loopParen(FICL_VM *pVM)
-{
- FICL_INT index = stackGetTop(pVM->rStack).i;
- FICL_INT limit = stackFetch(pVM->rStack, 1).i;
-
- index++;
-
- if (index >= limit)
- {
- stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
- vmBranchRelative(pVM, 1); /* fall through the loop */
- }
- else
- { /* update index, branch to loop head */
- stackSetTop(pVM->rStack, LVALUEtoCELL(index));
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-static void plusLoopParen(FICL_VM *pVM)
-{
- FICL_INT index,limit,increment;
- int flag;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- index = stackGetTop(pVM->rStack).i;
- limit = stackFetch(pVM->rStack, 1).i;
- increment = POP().i;
-
- index += increment;
-
- if (increment < 0)
- flag = (index < limit);
- else
- flag = (index >= limit);
-
- if (flag)
- {
- stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
- vmBranchRelative(pVM, 1); /* fall through the loop */
- }
- else
- { /* update index, branch to loop head */
- stackSetTop(pVM->rStack, LVALUEtoCELL(index));
- vmBranchRelative(pVM, *(int *)(pVM->ip));
- }
-
- return;
-}
-
-
-static void loopICo(FICL_VM *pVM)
-{
- CELL index = stackGetTop(pVM->rStack);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-static void loopJCo(FICL_VM *pVM)
-{
- CELL index = stackFetch(pVM->rStack, 3);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-static void loopKCo(FICL_VM *pVM)
-{
- CELL index = stackFetch(pVM->rStack, 6);
- stackPush(pVM->pStack, index);
-
- return;
-}
-
-
-/**************************************************************************
- r e t u r n s t a c k
-**
-**************************************************************************/
-static void toRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- stackPush(pVM->rStack, POP());
-}
-
-static void fromRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- PUSH(stackPop(pVM->rStack));
-}
-
-static void fetchRStack(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- PUSH(stackGetTop(pVM->rStack));
-}
-
-static void twoToR(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
- stackRoll(pVM->pStack, 1);
- stackPush(pVM->rStack, stackPop(pVM->pStack));
- stackPush(pVM->rStack, stackPop(pVM->pStack));
- return;
-}
-
-static void twoRFrom(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, stackPop(pVM->rStack));
- stackPush(pVM->pStack, stackPop(pVM->rStack));
- stackRoll(pVM->pStack, 1);
- return;
-}
-
-static void twoRFetch(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
- stackPush(pVM->pStack, stackFetch(pVM->rStack, 1));
- stackPush(pVM->pStack, stackFetch(pVM->rStack, 0));
- return;
-}
-
-
-/**************************************************************************
- v a r i a b l e
-**
-**************************************************************************/
-
-static void variableParen(FICL_VM *pVM)
-{
- FICL_WORD *fw;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- fw = pVM->runningWord;
- PUSHPTR(fw->param);
-}
-
-
-static void variable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- return;
-}
-
-
-static void twoVariable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
- dictAllotCells(dp, 2);
- return;
-}
-
-
-/**************************************************************************
- b a s e & f r i e n d s
-**
-**************************************************************************/
-
-static void base(FICL_VM *pVM)
-{
- CELL *pBase;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pBase = (CELL *)(&pVM->base);
- stackPush(pVM->pStack, LVALUEtoCELL(pBase));
- return;
-}
-
-
-static void decimal(FICL_VM *pVM)
-{
- pVM->base = 10;
- return;
-}
-
-
-static void hex(FICL_VM *pVM)
-{
- pVM->base = 16;
- return;
-}
-
-
-/**************************************************************************
- a l l o t & f r i e n d s
-**
-**************************************************************************/
-
-static void allot(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- i = POPINT();
-
-#if FICL_ROBUST
- dictCheck(dp, pVM, i);
-#endif
-
- dictAllot(dp, i);
- return;
-}
-
-
-static void here(FICL_VM *pVM)
-{
- FICL_DICT *dp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- dp = vmGetDict(pVM);
- PUSHPTR(dp->here);
- return;
-}
-
-static void comma(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- CELL c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- c = POP();
- dictAppendCell(dp, c);
- return;
-}
-
-static void cComma(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- char c;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- dp = vmGetDict(pVM);
- c = (char)POPINT();
- dictAppendChar(dp, c);
- return;
-}
-
-static void cells(FICL_VM *pVM)
-{
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- i = POPINT();
- PUSHINT(i * (FICL_INT)sizeof (CELL));
- return;
-}
-
-static void cellPlus(FICL_VM *pVM)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- cp = POPPTR();
- PUSHPTR(cp + sizeof (CELL));
- return;
-}
-
-
-
-/**************************************************************************
- t i c k
-** tick CORE ( "<spaces>name" -- xt )
-** Skip leading space delimiters. Parse name delimited by a space. Find
-** name and return xt, the execution token for name. An ambiguous condition
-** exists if name is not found.
-**************************************************************************/
-void ficlTick(FICL_VM *pVM)
-{
- FICL_WORD *pFW = NULL;
- STRINGINFO si = vmGetWord(pVM);
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pFW = dictLookup(vmGetDict(pVM), si);
- if (!pFW)
- {
- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
- PUSHPTR(pFW);
- return;
-}
-
-
-static void bracketTickCoIm(FICL_VM *pVM)
-{
- ficlTick(pVM);
- literalIm(pVM);
-
- return;
-}
-
-
-/**************************************************************************
- p o s t p o n e
-** Lookup the next word in the input stream and compile code to
-** insert it into definitions created by the resulting word
-** (defers compilation, even of immediate words)
-**************************************************************************/
-
-static void postponeCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
- FICL_WORD *pComma = ficlLookup(pVM->pSys, ",");
- assert(pComma);
-
- ficlTick(pVM);
- pFW = stackGetTop(pVM->pStack).p;
- if (wordIsImmediate(pFW))
- {
- dictAppendCell(dp, stackPop(pVM->pStack));
- }
- else
- {
- literalIm(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pComma));
- }
-
- return;
-}
-
-
-
-/**************************************************************************
- e x e c u t e
-** Pop an execution token (pointer to a word) off the stack and
-** run it
-**************************************************************************/
-
-static void execute(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- pFW = stackPopPtr(pVM->pStack);
- vmExecute(pVM, pFW);
-
- return;
-}
-
-
-/**************************************************************************
- i m m e d i a t e
-** Make the most recently compiled word IMMEDIATE -- it executes even
-** in compile state (most often used for control compiling words
-** such as IF, THEN, etc)
-**************************************************************************/
-
-static void immediate(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetImmediate(vmGetDict(pVM));
- return;
-}
-
-
-static void compileOnly(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetFlags(vmGetDict(pVM), FW_COMPILE, 0);
- return;
-}
-
-
-static void setObjectFlag(FICL_VM *pVM)
-{
- IGNORE(pVM);
- dictSetFlags(vmGetDict(pVM), FW_ISOBJECT, 0);
- return;
-}
-
-static void isObject(FICL_VM *pVM)
-{
- int flag;
- FICL_WORD *pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
-
- flag = ((pFW != NULL) && (pFW->flags & FW_ISOBJECT)) ? FICL_TRUE : FICL_FALSE;
- stackPushINT(pVM->pStack, flag);
- return;
-}
-
-static void cstringLit(FICL_VM *pVM)
-{
- FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
-
- char *cp = sp->text;
- cp += sp->count + 1;
- cp = alignPtr(cp);
- pVM->ip = (IPTYPE)(void *)cp;
-
- stackPushPtr(pVM->pStack, sp);
- return;
-}
-
-
-static void cstringQuoteIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- if (pVM->state == INTERPRET)
- {
- FICL_STRING *sp = (FICL_STRING *) dp->here;
- vmGetString(pVM, sp, '\"');
- stackPushPtr(pVM->pStack, sp);
- /* move HERE past string so it doesn't get overwritten. --lch */
- dictAllot(dp, sp->count + sizeof(FICL_COUNT));
- }
- else /* COMPILE state */
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pCStringLit));
- dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
- dictAlign(dp);
- }
-
- return;
-}
-
-/**************************************************************************
- d o t Q u o t e
-** IMMEDIATE word that compiles a string literal for later display
-** Compile stringLit, then copy the bytes of the string from the TIB
-** to the dictionary. Backpatch the count byte and align the dictionary.
-**
-** stringlit: Fetch the count from the dictionary, then push the address
-** and count on the stack. Finally, update ip to point to the first
-** aligned address after the string text.
-**************************************************************************/
-
-static void stringLit(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- FICL_COUNT count;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 2);
-#endif
-
- sp = (FICL_STRING *)(pVM->ip);
- count = sp->count;
- cp = sp->text;
- PUSHPTR(cp);
- PUSHUNS(count);
- cp += count + 1;
- cp = alignPtr(cp);
- pVM->ip = (IPTYPE)(void *)cp;
-}
-
-static void dotQuoteCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pType = ficlLookup(pVM->pSys, "type");
- assert(pType);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
- dictAlign(dp);
- dictAppendCell(dp, LVALUEtoCELL(pType));
- return;
-}
-
-
-static void dotParen(FICL_VM *pVM)
-{
- char *pSrc = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- char *pDest = pVM->pad;
- char ch;
-
- /*
- ** Note: the standard does not want leading spaces skipped (apparently)
- */
- for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
- *pDest++ = ch;
-
- *pDest = '\0';
- if ((pEnd != pSrc) && (ch == ')'))
- pSrc++;
-
- vmTextOut(pVM, pVM->pad, 0);
- vmUpdateTib(pVM, pSrc);
-
- return;
-}
-
-
-/**************************************************************************
- s l i t e r a l
-** STRING
-** Interpretation: Interpretation semantics for this word are undefined.
-** Compilation: ( c-addr1 u -- )
-** Append the run-time semantics given below to the current definition.
-** Run-time: ( -- c-addr2 u )
-** Return c-addr2 u describing a string consisting of the characters
-** specified by c-addr1 u during compilation. A program shall not alter
-** the returned string.
-**************************************************************************/
-static void sLiteralCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp;
- char *cp, *cpDest;
- FICL_UNS u;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
-
- dp = vmGetDict(pVM);
- u = POPUNS();
- cp = POPPTR();
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- cpDest = (char *) dp->here;
- *cpDest++ = (char) u;
-
- for (; u > 0; --u)
- {
- *cpDest++ = *cp++;
- }
-
- *cpDest++ = 0;
- dp->here = PTRtoCELL alignPtr(cpDest);
- return;
-}
-
-
-/**************************************************************************
- s t a t e
-** Return the address of the VM's state member (must be sized the
-** same as a CELL for this reason)
-**************************************************************************/
-static void state(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
- PUSHPTR(&pVM->state);
- return;
-}
-
-
-/**************************************************************************
- c r e a t e . . . d o e s >
-** Make a new word in the dictionary with the run-time effect of
-** a variable (push my address), but with extra space allotted
-** for use by does> .
-**************************************************************************/
-
-static void createParen(FICL_VM *pVM)
-{
- CELL *pCell;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pCell = pVM->runningWord->param;
- PUSHPTR(pCell+1);
- return;
-}
-
-
-static void create(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
-
- dictAppendWord2(dp, si, createParen, FW_DEFAULT);
- dictAllotCells(dp, 1);
- return;
-}
-
-
-static void doDoes(FICL_VM *pVM)
-{
- CELL *pCell;
- IPTYPE tempIP;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 0, 1);
-#endif
-
- pCell = pVM->runningWord->param;
- tempIP = (IPTYPE)((*pCell).p);
- PUSHPTR(pCell+1);
- vmPushIP(pVM, tempIP);
- return;
-}
-
-
-static void doesParen(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- dp->smudge->code = doDoes;
- dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
- vmPopIP(pVM);
- return;
-}
-
-
-static void doesCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-#if FICL_WANT_LOCALS
- assert(pVM->pSys->pUnLinkParen);
- if (pVM->pSys->nLocals > 0)
- {
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- dictEmpty(pLoc, pLoc->pForthWords->size);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pUnLinkParen));
- }
-
- pVM->pSys->nLocals = 0;
-#endif
- IGNORE(pVM);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pDoesParen));
- return;
-}
-
-
-/**************************************************************************
- t o b o d y
-** to-body CORE ( xt -- a-addr )
-** a-addr is the data-field address corresponding to xt. An ambiguous
-** condition exists if xt is not for a word defined via CREATE.
-**************************************************************************/
-static void toBody(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-/*#$-GUY CHANGE: Added robustness.-$#*/
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- pFW = POPPTR();
- PUSHPTR(pFW->param + 1);
- return;
-}
-
-
-/*
-** from-body ficl ( a-addr -- xt )
-** Reverse effect of >body
-*/
-static void fromBody(FICL_VM *pVM)
-{
- char *ptr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 1);
-#endif
-
- ptr = (char *)POPPTR() - sizeof (FICL_WORD);
- PUSHPTR(ptr);
- return;
-}
-
-
-/*
-** >name ficl ( xt -- c-addr u )
-** Push the address and length of a word's name given its address
-** xt.
-*/
-static void toName(FICL_VM *pVM)
-{
- FICL_WORD *pFW;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 2);
-#endif
-
- pFW = POPPTR();
- PUSHPTR(pFW->name);
- PUSHUNS(pFW->nName);
- return;
-}
-
-
-static void getLastWord(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_WORD *wp = pDict->smudge;
- assert(wp);
- vmPush(pVM, LVALUEtoCELL(wp));
- return;
-}
-
-
-/**************************************************************************
- l b r a c k e t e t c
-**
-**************************************************************************/
-
-static void lbracketCoIm(FICL_VM *pVM)
-{
- pVM->state = INTERPRET;
- return;
-}
-
-
-static void rbracket(FICL_VM *pVM)
-{
- pVM->state = COMPILE;
- return;
-}
-
-
-/**************************************************************************
- p i c t u r e d n u m e r i c w o r d s
-**
-** less-number-sign CORE ( -- )
-** Initialize the pictured numeric output conversion process.
-** (clear the pad)
-**************************************************************************/
-static void lessNumberSign(FICL_VM *pVM)
-{
- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- sp->count = 0;
- return;
-}
-
-/*
-** number-sign CORE ( ud1 -- ud2 )
-** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
-** n. (n is the least-significant digit of ud1.) Convert n to external form
-** and add the resulting character to the beginning of the pictured numeric
-** output string. An ambiguous condition exists if # executes outside of a
-** <# #> delimited number conversion.
-*/
-static void numberSign(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- DPUNS u;
- UNS16 rem;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- u = u64Pop(pVM->pStack);
- rem = m64UMod(&u, (UNS16)(pVM->base));
- sp->text[sp->count++] = digit_to_char(rem);
- u64Push(pVM->pStack, u);
- return;
-}
-
-/*
-** number-sign-greater CORE ( xd -- c-addr u )
-** Drop xd. Make the pictured numeric output string available as a character
-** string. c-addr and u specify the resulting character string. A program
-** may replace characters within the string.
-*/
-static void numberSignGreater(FICL_VM *pVM)
-{
- FICL_STRING *sp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- sp->text[sp->count] = 0;
- strrev(sp->text);
- DROP(2);
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- return;
-}
-
-/*
-** number-sign-s CORE ( ud1 -- ud2 )
-** Convert one digit of ud1 according to the rule for #. Continue conversion
-** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
-** #S executes outside of a <# #> delimited number conversion.
-** TO DO: presently does not use ud1 hi cell - use it!
-*/
-static void numberSignS(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- DPUNS u;
- UNS16 rem;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 2);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- u = u64Pop(pVM->pStack);
-
- do
- {
- rem = m64UMod(&u, (UNS16)(pVM->base));
- sp->text[sp->count++] = digit_to_char(rem);
- }
- while (u.hi || u.lo);
-
- u64Push(pVM->pStack, u);
- return;
-}
-
-/*
-** HOLD CORE ( char -- )
-** Add char to the beginning of the pictured numeric output string. An ambiguous
-** condition exists if HOLD executes outside of a <# #> delimited number conversion.
-*/
-static void hold(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- i = POPINT();
- sp->text[sp->count++] = (char) i;
- return;
-}
-
-/*
-** SIGN CORE ( n -- )
-** If n is negative, add a minus sign to the beginning of the pictured
-** numeric output string. An ambiguous condition exists if SIGN
-** executes outside of a <# #> delimited number conversion.
-*/
-static void sign(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- int i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- sp = PTRtoSTRING pVM->pad;
- i = POPINT();
- if (i < 0)
- sp->text[sp->count++] = '-';
- return;
-}
-
-
-/**************************************************************************
- t o N u m b e r
-** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
-** ud2 is the unsigned result of converting the characters within the
-** string specified by c-addr1 u1 into digits, using the number in BASE,
-** and adding each into ud1 after multiplying ud1 by the number in BASE.
-** Conversion continues left-to-right until a character that is not
-** convertible, including any + or -, is encountered or the string is
-** entirely converted. c-addr2 is the location of the first unconverted
-** character or the first character past the end of the string if the string
-** was entirely converted. u2 is the number of unconverted characters in the
-** string. An ambiguous condition exists if ud2 overflows during the
-** conversion.
-**************************************************************************/
-static void toNumber(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
- DPUNS accum;
- FICL_UNS base = pVM->base;
- FICL_UNS ch;
- FICL_UNS digit;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,4,4);
-#endif
-
- count = POPUNS();
- cp = (char *)POPPTR();
- accum = u64Pop(pVM->pStack);
-
- for (ch = *cp; count > 0; ch = *++cp, count--)
- {
- if (ch < '0')
- break;
-
- digit = ch - '0';
-
- if (digit > 9)
- digit = tolower(ch) - 'a' + 10;
- /*
- ** Note: following test also catches chars between 9 and a
- ** because 'digit' is unsigned!
- */
- if (digit >= base)
- break;
-
- accum = m64Mac(accum, base, digit);
- }
-
- u64Push(pVM->pStack, accum);
- PUSHPTR(cp);
- PUSHUNS(count);
-
- return;
-}
-
-
-
-/**************************************************************************
- q u i t & a b o r t
-** quit CORE ( -- ) ( R: i*x -- )
-** Empty the return stack, store zero in SOURCE-ID if it is present, make
-** the user input device the input source, and enter interpretation state.
-** Do not display a message. Repeat the following:
-**
-** Accept a line from the input source into the input buffer, set >IN to
-** zero, and interpret.
-** Display the implementation-defined system prompt if in
-** interpretation state, all processing has been completed, and no
-** ambiguous condition exists.
-**************************************************************************/
-
-static void quit(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_QUIT);
- return;
-}
-
-
-static void ficlAbort(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_ABORT);
- return;
-}
-
-
-/**************************************************************************
- a c c e p t
-** accept CORE ( c-addr +n1 -- +n2 )
-** Receive a string of at most +n1 characters. An ambiguous condition
-** exists if +n1 is zero or greater than 32,767. Display graphic characters
-** as they are received. A program that depends on the presence or absence
-** of non-graphic characters in the string has an environmental dependency.
-** The editing functions, if any, that the system performs in order to
-** construct the string are implementation-defined.
-**
-** (Although the standard text doesn't say so, I assume that the intent
-** of 'accept' is to store the string at the address specified on
-** the stack.)
-** Implementation: if there's more text in the TIB, use it. Otherwise
-** throw out for more text. Copy characters up to the max count into the
-** address given, and return the number of actual characters copied.
-**
-** Note (sobral) this may not be the behavior you'd expect if you're
-** trying to get user input at load time!
-**************************************************************************/
-static void accept(FICL_VM *pVM)
-{
- FICL_UNS count, len;
- char *cp;
- char *pBuf, *pEnd;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- pBuf = vmGetInBuf(pVM);
- pEnd = vmGetInBufEnd(pVM);
- len = pEnd - pBuf;
- if (len == 0)
- vmThrow(pVM, VM_RESTART);
-
- /*
- ** Now we have something in the text buffer - use it
- */
- count = stackPopINT(pVM->pStack);
- cp = stackPopPtr(pVM->pStack);
-
- len = (count < len) ? count : len;
- strncpy(cp, vmGetInBuf(pVM), len);
- pBuf += len;
- vmUpdateTib(pVM, pBuf);
- PUSHINT(len);
-
- return;
-}
-
-
-/**************************************************************************
- a l i g n
-** 6.1.0705 ALIGN CORE ( -- )
-** If the data-space pointer is not aligned, reserve enough space to
-** align it.
-**************************************************************************/
-static void align(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- IGNORE(pVM);
- dictAlign(dp);
- return;
-}
-
-
-/**************************************************************************
- a l i g n e d
-**
-**************************************************************************/
-static void aligned(FICL_VM *pVM)
-{
- void *addr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- addr = POPPTR();
- PUSHPTR(alignPtr(addr));
- return;
-}
-
-
-/**************************************************************************
- b e g i n & f r i e n d s
-** Indefinite loop control structures
-** A.6.1.0760 BEGIN
-** Typical use:
-** : X ... BEGIN ... test UNTIL ;
-** or
-** : X ... BEGIN ... test WHILE ... REPEAT ;
-**************************************************************************/
-static void beginCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- markBranch(dp, pVM, destTag);
- return;
-}
-
-static void untilCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pIfParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
- resolveBackBranch(dp, pVM, destTag);
- return;
-}
-
-static void whileCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pIfParen);
-
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pIfParen));
- markBranch(dp, pVM, origTag);
- twoSwap(pVM);
- dictAppendUNS(dp, 1);
- return;
-}
-
-static void repeatCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
-
- /* expect "begin" branch marker */
- resolveBackBranch(dp, pVM, destTag);
- /* expect "while" branch marker */
- resolveForwardBranch(dp, pVM, origTag);
- return;
-}
-
-
-static void againCoIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- assert(pVM->pSys->pBranchParen);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pBranchParen));
-
- /* expect "begin" branch marker */
- resolveBackBranch(dp, pVM, destTag);
- return;
-}
-
-
-/**************************************************************************
- c h a r & f r i e n d s
-** 6.1.0895 CHAR CORE ( "<spaces>name" -- char )
-** Skip leading space delimiters. Parse name delimited by a space.
-** Put the value of its first character onto the stack.
-**
-** bracket-char CORE
-** Interpretation: Interpretation semantics for this word are undefined.
-** Compilation: ( "<spaces>name" -- )
-** Skip leading space delimiters. Parse name delimited by a space.
-** Append the run-time semantics given below to the current definition.
-** Run-time: ( -- char )
-** Place char, the value of the first character of name, on the stack.
-**************************************************************************/
-static void ficlChar(FICL_VM *pVM)
-{
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,1);
-#endif
-
- si = vmGetWord(pVM);
- PUSHUNS((FICL_UNS)(si.cp[0]));
- return;
-}
-
-static void charCoIm(FICL_VM *pVM)
-{
- ficlChar(pVM);
- literalIm(pVM);
- return;
-}
-
-/**************************************************************************
- c h a r P l u s
-** char-plus CORE ( c-addr1 -- c-addr2 )
-** Add the size in address units of a character to c-addr1, giving c-addr2.
-**************************************************************************/
-static void charPlus(FICL_VM *pVM)
-{
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- cp = POPPTR();
- PUSHPTR(cp + 1);
- return;
-}
-
-/**************************************************************************
- c h a r s
-** chars CORE ( n1 -- n2 )
-** n2 is the size in address units of n1 characters.
-** For most processors, this function can be a no-op. To guarantee
-** portability, we'll multiply by sizeof (char).
-**************************************************************************/
-#if defined (_M_IX86)
-#pragma warning(disable: 4127)
-#endif
-static void ficlChars(FICL_VM *pVM)
-{
- if (sizeof (char) > 1)
- {
- FICL_INT i;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
- i = POPINT();
- PUSHINT(i * sizeof (char));
- }
- /* otherwise no-op! */
- return;
-}
-#if defined (_M_IX86)
-#pragma warning(default: 4127)
-#endif
-
-
-/**************************************************************************
- c o u n t
-** COUNT CORE ( c-addr1 -- c-addr2 u )
-** Return the character string specification for the counted string stored
-** at c-addr1. c-addr2 is the address of the first character after c-addr1.
-** u is the contents of the character at c-addr1, which is the length in
-** characters of the string at c-addr2.
-**************************************************************************/
-static void count(FICL_VM *pVM)
-{
- FICL_STRING *sp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- sp = POPPTR();
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- return;
-}
-
-/**************************************************************************
- e n v i r o n m e n t ?
-** environment-query CORE ( c-addr u -- false | i*x true )
-** c-addr is the address of a character string and u is the string's
-** character count. u may have a value in the range from zero to an
-** implementation-defined maximum which shall not be less than 31. The
-** character string should contain a keyword from 3.2.6 Environmental
-** queries or the optional word sets to be checked for correspondence
-** with an attribute of the present environment. If the system treats the
-** attribute as unknown, the returned flag is false; otherwise, the flag
-** is true and the i*x returned is of the type specified in the table for
-** the attribute queried.
-**************************************************************************/
-static void environmentQ(FICL_VM *pVM)
-{
- FICL_DICT *envp;
- FICL_WORD *pFW;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- envp = pVM->pSys->envp;
- si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
- si.cp = stackPopPtr(pVM->pStack);
-
- pFW = dictLookup(envp, si);
-
- if (pFW != NULL)
- {
- vmExecute(pVM, pFW);
- PUSHINT(FICL_TRUE);
- }
- else
- {
- PUSHINT(FICL_FALSE);
- }
- return;
-}
-
-/**************************************************************************
- e v a l u a t e
-** EVALUATE CORE ( i*x c-addr u -- j*x )
-** Save the current input source specification. Store minus-one (-1) in
-** SOURCE-ID if it is present. Make the string described by c-addr and u
-** both the input source and input buffer, set >IN to zero, and interpret.
-** When the parse area is empty, restore the prior input source
-** specification. Other stack effects are due to the words EVALUATEd.
-**
-**************************************************************************/
-static void evaluate(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
- CELL id;
- int result;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,0);
-#endif
-
- count = POPUNS();
- cp = POPPTR();
-
- IGNORE(count);
- id = pVM->sourceID;
- pVM->sourceID.i = -1;
- result = ficlExecC(pVM, cp, count);
- pVM->sourceID = id;
- if (result != VM_OUTOFTEXT)
- vmThrow(pVM, result);
-
- return;
-}
-
-
-/**************************************************************************
- s t r i n g q u o t e
-** Interpreting: get string delimited by a quote from the input stream,
-** copy to a scratch area, and put its count and address on the stack.
-** Compiling: compile code to push the address and count of a string
-** literal, compile the string from the input stream, and align the dict
-** pointer.
-**************************************************************************/
-static void stringQuoteIm(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
-
- if (pVM->state == INTERPRET)
- {
- FICL_STRING *sp = (FICL_STRING *) dp->here;
- vmGetString(pVM, sp, '\"');
- PUSHPTR(sp->text);
- PUSHUNS(sp->count);
- }
- else /* COMPILE state */
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStringLit));
- dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
- dictAlign(dp);
- }
-
- return;
-}
-
-
-/**************************************************************************
- t y p e
-** Pop count and char address from stack and print the designated string.
-**************************************************************************/
-static void type(FICL_VM *pVM)
-{
- FICL_UNS count;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 2, 0);
-#endif
-
- count = POPUNS();
- cp = POPPTR();
-
- /*
- ** Since we don't have an output primitive for a counted string
- ** (oops), make sure the string is null terminated. If not, copy
- ** and terminate it.
- */
- if (cp[count] != 0)
- {
- char *pDest = (char *)vmGetDict(pVM)->here;
- if (cp != pDest)
- strncpy(pDest, cp, count);
-
- pDest[count] = '\0';
- cp = pDest;
- }
-
- vmTextOut(pVM, cp, 0);
- return;
-}
-
-/**************************************************************************
- w o r d
-** word CORE ( char "<chars>ccc<char>" -- c-addr )
-** Skip leading delimiters. Parse characters ccc delimited by char. An
-** ambiguous condition exists if the length of the parsed string is greater
-** than the implementation-defined length of a counted string.
-**
-** c-addr is the address of a transient region containing the parsed word
-** as a counted string. If the parse area was empty or contained no
-** characters other than the delimiter, the resulting string has a zero
-** length. A space, not included in the length, follows the string. A
-** program may replace characters within the string.
-** NOTE! Ficl also NULL-terminates the dest string.
-**************************************************************************/
-static void ficlWord(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- char delim;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,1);
-#endif
-
- sp = (FICL_STRING *)pVM->pad;
- delim = (char)POPINT();
- si = vmParseStringEx(pVM, delim, 1);
-
- if (SI_COUNT(si) > nPAD-1)
- SI_SETLEN(si, nPAD-1);
-
- sp->count = (FICL_COUNT)SI_COUNT(si);
- strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
- /*#$-GUY CHANGE: I added this.-$#*/
- sp->text[sp->count] = 0;
- strcat(sp->text, " ");
-
- PUSHPTR(sp);
- return;
-}
-
-
-/**************************************************************************
- p a r s e - w o r d
-** ficl PARSE-WORD ( <spaces>name -- c-addr u )
-** Skip leading spaces and parse name delimited by a space. c-addr is the
-** address within the input buffer and u is the length of the selected
-** string. If the parse area is empty, the resulting string has a zero length.
-**************************************************************************/
-static void parseNoCopy(FICL_VM *pVM)
-{
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,2);
-#endif
-
- si = vmGetWord0(pVM);
- PUSHPTR(SI_PTR(si));
- PUSHUNS(SI_COUNT(si));
- return;
-}
-
-
-/**************************************************************************
- p a r s e
-** CORE EXT ( char "ccc<char>" -- c-addr u )
-** Parse ccc delimited by the delimiter char.
-** c-addr is the address (within the input buffer) and u is the length of
-** the parsed string. If the parse area was empty, the resulting string has
-** a zero length.
-** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
-**************************************************************************/
-static void parse(FICL_VM *pVM)
-{
- STRINGINFO si;
- char delim;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- delim = (char)POPINT();
-
- si = vmParseStringEx(pVM, delim, 0);
- PUSHPTR(SI_PTR(si));
- PUSHUNS(SI_COUNT(si));
- return;
-}
-
-
-/**************************************************************************
- f i l l
-** CORE ( c-addr u char -- )
-** If u is greater than zero, store char in each of u consecutive
-** characters of memory beginning at c-addr.
-**************************************************************************/
-static void fill(FICL_VM *pVM)
-{
- char ch;
- FICL_UNS u;
- char *cp;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,0);
-#endif
- ch = (char)POPINT();
- u = POPUNS();
- cp = (char *)POPPTR();
-
- while (u > 0)
- {
- *cp++ = ch;
- u--;
- }
- return;
-}
-
-
-/**************************************************************************
- f i n d
-** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
-** Find the definition named in the counted string at c-addr. If the
-** definition is not found, return c-addr and zero. If the definition is
-** found, return its execution token xt. If the definition is immediate,
-** also return one (1), otherwise also return minus-one (-1). For a given
-** string, the values returned by FIND while compiling may differ from
-** those returned while not compiling.
-**************************************************************************/
-static void do_find(FICL_VM *pVM, STRINGINFO si, void *returnForFailure)
-{
- FICL_WORD *pFW;
-
- pFW = dictLookup(vmGetDict(pVM), si);
- if (pFW)
- {
- PUSHPTR(pFW);
- PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
- }
- else
- {
- PUSHPTR(returnForFailure);
- PUSHUNS(0);
- }
- return;
-}
-
-
-
-/**************************************************************************
- f i n d
-** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 )
-** Find the definition named in the counted string at c-addr. If the
-** definition is not found, return c-addr and zero. If the definition is
-** found, return its execution token xt. If the definition is immediate,
-** also return one (1), otherwise also return minus-one (-1). For a given
-** string, the values returned by FIND while compiling may differ from
-** those returned while not compiling.
-**************************************************************************/
-static void cFind(FICL_VM *pVM)
-{
- FICL_STRING *sp;
- STRINGINFO si;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
- sp = POPPTR();
- SI_PFS(si, sp);
- do_find(pVM, si, sp);
-}
-
-
-
-/**************************************************************************
- s f i n d
-** FICL ( c-addr u -- 0 0 | xt 1 | xt -1 )
-** Like FIND, but takes "c-addr u" for the string.
-**************************************************************************/
-static void sFind(FICL_VM *pVM)
-{
- STRINGINFO si;
-
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,2);
-#endif
-
- si.count = stackPopINT(pVM->pStack);
- si.cp = stackPopPtr(pVM->pStack);
-
- do_find(pVM, si, NULL);
-}
-
-
-
-/**************************************************************************
- f m S l a s h M o d
-** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
-** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
-** Input and output stack arguments are signed. An ambiguous condition
-** exists if n1 is zero or if the quotient lies outside the range of a
-** single-cell signed integer.
-**************************************************************************/
-static void fmSlashMod(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,2);
-#endif
-
- n1 = POPINT();
- d1 = i64Pop(pVM->pStack);
- qr = m64FlooredDivI(d1, n1);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- s m S l a s h R e m
-** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
-** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
-** Input and output stack arguments are signed. An ambiguous condition
-** exists if n1 is zero or if the quotient lies outside the range of a
-** single-cell signed integer.
-**************************************************************************/
-static void smSlashRem(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,2);
-#endif
-
- n1 = POPINT();
- d1 = i64Pop(pVM->pStack);
- qr = m64SymmetricDivI(d1, n1);
- PUSHINT(qr.rem);
- PUSHINT(qr.quot);
- return;
-}
-
-
-static void ficlMod(FICL_VM *pVM)
-{
- DPINT d1;
- FICL_INT n1;
- INTQR qr;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n1 = POPINT();
- d1.lo = POPINT();
- i64Extend(d1);
- qr = m64SymmetricDivI(d1, n1);
- PUSHINT(qr.rem);
- return;
-}
-
-
-/**************************************************************************
- u m S l a s h M o d
-** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
-** Divide ud by u1, giving the quotient u3 and the remainder u2.
-** All values and arithmetic are unsigned. An ambiguous condition
-** exists if u1 is zero or if the quotient lies outside the range of a
-** single-cell unsigned integer.
-*************************************************************************/
-static void umSlashMod(FICL_VM *pVM)
-{
- DPUNS ud;
- FICL_UNS u1;
- UNSQR qr;
-
- u1 = stackPopUNS(pVM->pStack);
- ud = u64Pop(pVM->pStack);
- qr = ficlLongDiv(ud, u1);
- PUSHUNS(qr.rem);
- PUSHUNS(qr.quot);
- return;
-}
-
-
-/**************************************************************************
- l s h i f t
-** l-shift CORE ( x1 u -- x2 )
-** Perform a logical left shift of u bit-places on x1, giving x2.
-** Put zeroes into the least significant bits vacated by the shift.
-** An ambiguous condition exists if u is greater than or equal to the
-** number of bits in a cell.
-**
-** r-shift CORE ( x1 u -- x2 )
-** Perform a logical right shift of u bit-places on x1, giving x2.
-** Put zeroes into the most significant bits vacated by the shift. An
-** ambiguous condition exists if u is greater than or equal to the
-** number of bits in a cell.
-**************************************************************************/
-static void lshift(FICL_VM *pVM)
-{
- FICL_UNS nBits;
- FICL_UNS x1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- nBits = POPUNS();
- x1 = POPUNS();
- PUSHUNS(x1 << nBits);
- return;
-}
-
-
-static void rshift(FICL_VM *pVM)
-{
- FICL_UNS nBits;
- FICL_UNS x1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- nBits = POPUNS();
- x1 = POPUNS();
-
- PUSHUNS(x1 >> nBits);
- return;
-}
-
-
-/**************************************************************************
- m S t a r
-** m-star CORE ( n1 n2 -- d )
-** d is the signed product of n1 times n2.
-**************************************************************************/
-static void mStar(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
- DPINT d;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,2);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- d = m64MulI(n1, n2);
- i64Push(pVM->pStack, d);
- return;
-}
-
-
-static void umStar(FICL_VM *pVM)
-{
- FICL_UNS u2;
- FICL_UNS u1;
- DPUNS ud;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,2);
-#endif
-
- u2 = POPUNS();
- u1 = POPUNS();
-
- ud = ficlLongMul(u1, u2);
- u64Push(pVM->pStack, ud);
- return;
-}
-
-
-/**************************************************************************
- m a x & m i n
-**
-**************************************************************************/
-static void ficlMax(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- PUSHINT((n1 > n2) ? n1 : n2);
- return;
-}
-
-static void ficlMin(FICL_VM *pVM)
-{
- FICL_INT n2;
- FICL_INT n1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,1);
-#endif
-
- n2 = POPINT();
- n1 = POPINT();
-
- PUSHINT((n1 < n2) ? n1 : n2);
- return;
-}
-
-
-/**************************************************************************
- m o v e
-** CORE ( addr1 addr2 u -- )
-** If u is greater than zero, copy the contents of u consecutive address
-** units at addr1 to the u consecutive address units at addr2. After MOVE
-** completes, the u consecutive address units at addr2 contain exactly
-** what the u consecutive address units at addr1 contained before the move.
-** NOTE! This implementation assumes that a char is the same size as
-** an address unit.
-**************************************************************************/
-static void move(FICL_VM *pVM)
-{
- FICL_UNS u;
- char *addr2;
- char *addr1;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,3,0);
-#endif
-
- u = POPUNS();
- addr2 = POPPTR();
- addr1 = POPPTR();
-
- if (u == 0)
- return;
- /*
- ** Do the copy carefully, so as to be
- ** correct even if the two ranges overlap
- */
- if (addr1 >= addr2)
- {
- for (; u > 0; u--)
- *addr2++ = *addr1++;
- }
- else
- {
- addr2 += u-1;
- addr1 += u-1;
- for (; u > 0; u--)
- *addr2-- = *addr1--;
- }
-
- return;
-}
-
-
-/**************************************************************************
- r e c u r s e
-**
-**************************************************************************/
-static void recurseCoIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
-
- IGNORE(pVM);
- dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
- return;
-}
-
-
-/**************************************************************************
- s t o d
-** s-to-d CORE ( n -- d )
-** Convert the number n to the double-cell number d with the same
-** numerical value.
-**************************************************************************/
-static void sToD(FICL_VM *pVM)
-{
- FICL_INT s;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,1,2);
-#endif
-
- s = POPINT();
-
- /* sign extend to 64 bits.. */
- PUSHINT(s);
- PUSHINT((s < 0) ? -1 : 0);
- return;
-}
-
-
-/**************************************************************************
- s o u r c e
-** CORE ( -- c-addr u )
-** c-addr is the address of, and u is the number of characters in, the
-** input buffer.
-**************************************************************************/
-static void source(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,2);
-#endif
- PUSHPTR(pVM->tib.cp);
- PUSHINT(vmGetInBufLen(pVM));
- return;
-}
-
-
-/**************************************************************************
- v e r s i o n
-** non-standard...
-**************************************************************************/
-static void ficlVersion(FICL_VM *pVM)
-{
- vmTextOut(pVM, "ficl Version " FICL_VER, 1);
- return;
-}
-
-
-/**************************************************************************
- t o I n
-** to-in CORE
-**************************************************************************/
-static void toIn(FICL_VM *pVM)
-{
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,0,1);
-#endif
- PUSHPTR(&pVM->tib.index);
- return;
-}
-
-
-/**************************************************************************
- c o l o n N o N a m e
-** CORE EXT ( C: -- colon-sys ) ( S: -- xt )
-** Create an unnamed colon definition and push its address.
-** Change state to compile.
-**************************************************************************/
-static void colonNoName(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
- STRINGINFO si;
-
- SI_SETLEN(si, 0);
- SI_SETPTR(si, NULL);
-
- pVM->state = COMPILE;
- pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
- PUSHPTR(pFW);
- markControlTag(pVM, colonTag);
- return;
-}
-
-
-/**************************************************************************
- u s e r V a r i a b l e
-** user ( u -- ) "<spaces>name"
-** Get a name from the input stream and create a user variable
-** with the name and the index supplied. The run-time effect
-** of a user variable is to push the address of the indexed cell
-** in the running vm's user array.
-**
-** User variables are vm local cells. Each vm has an array of
-** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
-** Ficl's user facility is implemented with two primitives,
-** "user" and "(user)", a variable ("nUser") (in softcore.c) that
-** holds the index of the next free user cell, and a redefinition
-** (also in softcore) of "user" that defines a user word and increments
-** nUser.
-**************************************************************************/
-#if FICL_WANT_USER
-static void userParen(FICL_VM *pVM)
-{
- FICL_INT i = pVM->runningWord->param[0].i;
- PUSHPTR(&pVM->user[i]);
- return;
-}
-
-
-static void userVariable(FICL_VM *pVM)
-{
- FICL_DICT *dp = vmGetDict(pVM);
- STRINGINFO si = vmGetWord(pVM);
- CELL c;
-
- c = stackPop(pVM->pStack);
- if (c.i >= FICL_USER_CELLS)
- {
- vmThrowErr(pVM, "Error - out of user space");
- }
-
- dictAppendWord2(dp, si, userParen, FW_DEFAULT);
- dictAppendCell(dp, c);
- return;
-}
-#endif
-
-
-/**************************************************************************
- t o V a l u e
-** CORE EXT
-** Interpretation: ( x "<spaces>name" -- )
-** Skip leading spaces and parse name delimited by a space. Store x in
-** name. An ambiguous condition exists if name was not defined by VALUE.
-** NOTE: In ficl, VALUE is an alias of CONSTANT
-**************************************************************************/
-static void toValue(FICL_VM *pVM)
-{
- STRINGINFO si = vmGetWord(pVM);
- FICL_DICT *dp = vmGetDict(pVM);
- FICL_WORD *pFW;
-
-#if FICL_WANT_LOCALS
- if ((pVM->pSys->nLocals > 0) && (pVM->state == COMPILE))
- {
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- pFW = dictLookup(pLoc, si);
- if (pFW && (pFW->code == doLocalIm))
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pToLocalParen));
- dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
- return;
- }
- else if (pFW && pFW->code == do2LocalIm)
- {
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
- dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
- return;
- }
- }
-#endif
-
- assert(pVM->pSys->pStore);
-
- pFW = dictLookup(dp, si);
- if (!pFW)
- {
- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
-
- if (pVM->state == INTERPRET)
- pFW->param[0] = stackPop(pVM->pStack);
- else /* compile code to store to word's param */
- {
- PUSHPTR(&pFW->param[0]);
- literalIm(pVM);
- dictAppendCell(dp, LVALUEtoCELL(pVM->pSys->pStore));
- }
- return;
-}
-
-
-#if FICL_WANT_LOCALS
-/**************************************************************************
- l i n k P a r e n
-** ( -- )
-** Link a frame on the return stack, reserving nCells of space for
-** locals - the value of nCells is the next cell in the instruction
-** stream.
-**************************************************************************/
-static void linkParen(FICL_VM *pVM)
-{
- FICL_INT nLink = *(FICL_INT *)(pVM->ip);
- vmBranchRelative(pVM, 1);
- stackLink(pVM->rStack, nLink);
- return;
-}
-
-
-static void unlinkParen(FICL_VM *pVM)
-{
- stackUnlink(pVM->rStack);
- return;
-}
-
-
-/**************************************************************************
- d o L o c a l I m
-** Immediate - cfa of a local while compiling - when executed, compiles
-** code to fetch the value of a local given the local's index in the
-** word's pfa
-**************************************************************************/
-static void getLocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- return;
-}
-
-
-static void toLocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void getLocal0(FICL_VM *pVM)
-{
- stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
- return;
-}
-
-
-static void toLocal0(FICL_VM *pVM)
-{
- pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void getLocal1(FICL_VM *pVM)
-{
- stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
- return;
-}
-
-
-static void toLocal1(FICL_VM *pVM)
-{
- pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
- return;
-}
-
-
-/*
-** Each local is recorded in a private locals dictionary as a
-** word that does doLocalIm at runtime. DoLocalIm compiles code
-** into the client definition to fetch the value of the
-** corresponding local variable from the return stack.
-** The private dictionary gets initialized at the end of each block
-** that uses locals (in ; and does> for example).
-*/
-static void doLocalIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_INT nLocal = pVM->runningWord->param[0].i;
-
- if (pVM->state == INTERPRET)
- {
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- }
- else
- {
-
- if (nLocal == 0)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal0));
- }
- else if (nLocal == 1)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocal1));
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGetLocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocal));
- }
- }
- return;
-}
-
-
-/**************************************************************************
- l o c a l P a r e n
-** paren-local-paren LOCAL
-** Interpretation: Interpretation semantics for this word are undefined.
-** Execution: ( c-addr u -- )
-** When executed during compilation, (LOCAL) passes a message to the
-** system that has one of two meanings. If u is non-zero,
-** the message identifies a new local whose definition name is given by
-** the string of characters identified by c-addr u. If u is zero,
-** the message is last local and c-addr has no significance.
-**
-** The result of executing (LOCAL) during compilation of a definition is
-** to create a set of named local identifiers, each of which is
-** a definition name, that only have execution semantics within the scope
-** of that definition's source.
-**
-** local Execution: ( -- x )
-**
-** Push the local's value, x, onto the stack. The local's value is
-** initialized as described in 13.3.3 Processing locals and may be
-** changed by preceding the local's name with TO. An ambiguous condition
-** exists when local is executed while in interpretation state.
-**************************************************************************/
-static void localParen(FICL_VM *pVM)
-{
- FICL_DICT *pDict;
- STRINGINFO si;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM,2,0);
-#endif
-
- pDict = vmGetDict(pVM);
- SI_SETLEN(si, POPUNS());
- SI_SETPTR(si, (char *)POPPTR());
-
- if (SI_COUNT(si) > 0)
- { /* add a local to the **locals** dict and update nLocals */
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
- {
- vmThrowErr(pVM, "Error: out of local space");
- }
-
- dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
-
- if (pVM->pSys->nLocals == 0)
- { /* compile code to create a local stack frame */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
- /* save location in dictionary for #locals */
- pVM->pSys->pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- /* compile code to initialize first local */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal0));
- }
- else if (pVM->pSys->nLocals == 1)
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocal1));
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pToLocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- }
-
- (pVM->pSys->nLocals)++;
- }
- else if (pVM->pSys->nLocals > 0)
- { /* write nLocals to (link) param area in dictionary */
- *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
- }
-
- return;
-}
-
-
-static void get2LocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
- return;
-}
-
-
-static void do2LocalIm(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- FICL_INT nLocal = pVM->runningWord->param[0].i;
-
- if (pVM->state == INTERPRET)
- {
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
- stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
- }
- else
- {
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pGet2LocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(nLocal));
- }
- return;
-}
-
-
-static void to2LocalParen(FICL_VM *pVM)
-{
- FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
- pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
- pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
- return;
-}
-
-
-static void twoLocalParen(FICL_VM *pVM)
-{
- FICL_DICT *pDict = vmGetDict(pVM);
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
-
- if (SI_COUNT(si) > 0)
- { /* add a local to the **locals** dict and update nLocals */
- FICL_DICT *pLoc = ficlGetLoc(pVM->pSys);
- if (pVM->pSys->nLocals >= FICL_MAX_LOCALS)
- {
- vmThrowErr(pVM, "Error: out of local space");
- }
-
- dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
- dictAppendCell(pLoc, LVALUEtoCELL(pVM->pSys->nLocals));
-
- if (pVM->pSys->nLocals == 0)
- { /* compile code to create a local stack frame */
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pLinkParen));
- /* save location in dictionary for #locals */
- pVM->pSys->pMarkLocals = pDict->here;
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
- }
-
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->pTo2LocalParen));
- dictAppendCell(pDict, LVALUEtoCELL(pVM->pSys->nLocals));
-
- pVM->pSys->nLocals += 2;
- }
- else if (pVM->pSys->nLocals > 0)
- { /* write nLocals to (link) param area in dictionary */
- *(FICL_INT *)(pVM->pSys->pMarkLocals) = pVM->pSys->nLocals;
- }
-
- return;
-}
-
-
-#endif
-/**************************************************************************
- c o m p a r e
-** STRING ( c-addr1 u1 c-addr2 u2 -- n )
-** Compare the string specified by c-addr1 u1 to the string specified by
-** c-addr2 u2. The strings are compared, beginning at the given addresses,
-** character by character, up to the length of the shorter string or until a
-** difference is found. If the two strings are identical, n is zero. If the two
-** strings are identical up to the length of the shorter string, n is minus-one
-** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
-** identical up to the length of the shorter string, n is minus-one (-1) if the
-** first non-matching character in the string specified by c-addr1 u1 has a
-** lesser numeric value than the corresponding character in the string specified
-** by c-addr2 u2 and one (1) otherwise.
-**************************************************************************/
-static void compareInternal(FICL_VM *pVM, int caseInsensitive)
-{
- char *cp1, *cp2;
- FICL_UNS u1, u2, uMin;
- int n = 0;
-
- vmCheckStack(pVM, 4, 1);
- u2 = stackPopUNS(pVM->pStack);
- cp2 = (char *)stackPopPtr(pVM->pStack);
- u1 = stackPopUNS(pVM->pStack);
- cp1 = (char *)stackPopPtr(pVM->pStack);
-
- uMin = (u1 < u2)? u1 : u2;
- for ( ; (uMin > 0) && (n == 0); uMin--)
- {
- char c1 = *cp1++;
- char c2 = *cp2++;
- if (caseInsensitive)
- {
- c1 = (char)tolower(c1);
- c2 = (char)tolower(c2);
- }
- n = (int)(c1 - c2);
- }
-
- if (n == 0)
- n = (int)(u1 - u2);
-
- if (n < 0)
- n = -1;
- else if (n > 0)
- n = 1;
-
- PUSHINT(n);
- return;
-}
-
-
-static void compareString(FICL_VM *pVM)
-{
- compareInternal(pVM, FALSE);
-}
-
-
-static void compareStringInsensitive(FICL_VM *pVM)
-{
- compareInternal(pVM, TRUE);
-}
-
-
-/**************************************************************************
- p a d
-** CORE EXT ( -- c-addr )
-** c-addr is the address of a transient region that can be used to hold
-** data for intermediate processing.
-**************************************************************************/
-static void pad(FICL_VM *pVM)
-{
- stackPushPtr(pVM->pStack, pVM->pad);
-}
-
-
-/**************************************************************************
- s o u r c e - i d
-** CORE EXT, FILE ( -- 0 | -1 | fileid )
-** Identifies the input source as follows:
-**
-** SOURCE-ID Input source
-** --------- ------------
-** fileid Text file fileid
-** -1 String (via EVALUATE)
-** 0 User input device
-**************************************************************************/
-static void sourceid(FICL_VM *pVM)
-{
- PUSHINT(pVM->sourceID.i);
- return;
-}
-
-
-/**************************************************************************
- r e f i l l
-** CORE EXT ( -- flag )
-** Attempt to fill the input buffer from the input source, returning a true
-** flag if successful.
-** When the input source is the user input device, attempt to receive input
-** into the terminal input buffer. If successful, make the result the input
-** buffer, set >IN to zero, and return true. Receipt of a line containing no
-** characters is considered successful. If there is no input available from
-** the current input source, return false.
-** When the input source is a string from EVALUATE, return false and
-** perform no other action.
-**************************************************************************/
-static void refill(FICL_VM *pVM)
-{
- FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
- if (ret && (pVM->fRestart == 0))
- vmThrow(pVM, VM_RESTART);
-
- PUSHINT(ret);
- return;
-}
-
-
-/**************************************************************************
- freebsd exception handling words
-** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
-** the word in ToS. If an exception happens, restore the state to what
-** it was before, and pushes the exception value on the stack. If not,
-** push zero.
-**
-** Notice that Catch implements an inner interpreter. This is ugly,
-** but given how ficl works, it cannot be helped. The problem is that
-** colon definitions will be executed *after* the function returns,
-** while "code" definitions will be executed immediately. I considered
-** other solutions to this problem, but all of them shared the same
-** basic problem (with added disadvantages): if ficl ever changes it's
-** inner thread modus operandi, one would have to fix this word.
-**
-** More comments can be found throughout catch's code.
-**
-** Daniel C. Sobral Jan 09/1999
-** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
-**************************************************************************/
-
-static void ficlCatch(FICL_VM *pVM)
-{
- int except;
- jmp_buf vmState;
- FICL_VM VM;
- FICL_STACK pStack;
- FICL_STACK rStack;
- FICL_WORD *pFW;
-
- assert(pVM);
- assert(pVM->pSys->pExitInner);
-
-
- /*
- ** Get xt.
- ** We need this *before* we save the stack pointer, or
- ** we'll have to pop one element out of the stack after
- ** an exception. I prefer to get done with it up front. :-)
- */
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
- pFW = stackPopPtr(pVM->pStack);
-
- /*
- ** Save vm's state -- a catch will not back out environmental
- ** changes.
- **
- ** We are *not* saving dictionary state, since it is
- ** global instead of per vm, and we are not saving
- ** stack contents, since we are not required to (and,
- ** thus, it would be useless). We save pVM, and pVM
- ** "stacks" (a structure containing general information
- ** about it, including the current stack pointer).
- */
- memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
- memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
- memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
-
- /*
- ** Give pVM a jmp_buf
- */
- pVM->pState = &vmState;
-
- /*
- ** Safety net
- */
- except = setjmp(vmState);
-
- switch (except)
- {
- /*
- ** Setup condition - push poison pill so that the VM throws
- ** VM_INNEREXIT if the XT terminates normally, then execute
- ** the XT
- */
- case 0:
- vmPushIP(pVM, &(pVM->pSys->pExitInner)); /* Open mouth, insert emetic */
- vmExecute(pVM, pFW);
- vmInnerLoop(pVM);
- break;
-
- /*
- ** Normal exit from XT - lose the poison pill,
- ** restore old setjmp vector and push a zero.
- */
- case VM_INNEREXIT:
- vmPopIP(pVM); /* Gack - hurl poison pill */
- pVM->pState = VM.pState; /* Restore just the setjmp vector */
- PUSHINT(0); /* Push 0 -- everything is ok */
- break;
-
- /*
- ** Some other exception got thrown - restore pre-existing VM state
- ** and push the exception code
- */
- default:
- /* Restore vm's state */
- memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
- memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
- memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
-
- PUSHINT(except);/* Push error */
- break;
- }
-}
-
-/**************************************************************************
-** t h r o w
-** EXCEPTION
-** Throw -- From ANS Forth standard.
-**
-** Throw takes the ToS and, if that's different from zero,
-** returns to the last executed catch context. Further throws will
-** unstack previously executed "catches", in LIFO mode.
-**
-** Daniel C. Sobral Jan 09/1999
-**************************************************************************/
-static void ficlThrow(FICL_VM *pVM)
-{
- int except;
-
- except = stackPopINT(pVM->pStack);
-
- if (except)
- vmThrow(pVM, except);
-}
-
-
-/**************************************************************************
-** a l l o c a t e
-** MEMORY
-**************************************************************************/
-static void ansAllocate(FICL_VM *pVM)
-{
- size_t size;
- void *p;
-
- size = stackPopINT(pVM->pStack);
- p = ficlMalloc(size);
- PUSHPTR(p);
- if (p)
- PUSHINT(0);
- else
- PUSHINT(1);
-}
-
-
-/**************************************************************************
-** f r e e
-** MEMORY
-**************************************************************************/
-static void ansFree(FICL_VM *pVM)
-{
- void *p;
-
- p = stackPopPtr(pVM->pStack);
- ficlFree(p);
- PUSHINT(0);
-}
-
-
-/**************************************************************************
-** r e s i z e
-** MEMORY
-**************************************************************************/
-static void ansResize(FICL_VM *pVM)
-{
- size_t size;
- void *new, *old;
-
- size = stackPopINT(pVM->pStack);
- old = stackPopPtr(pVM->pStack);
- new = ficlRealloc(old, size);
- if (new)
- {
- PUSHPTR(new);
- PUSHINT(0);
- }
- else
- {
- PUSHPTR(old);
- PUSHINT(1);
- }
-}
-
-
-/**************************************************************************
-** e x i t - i n n e r
-** Signals execXT that an inner loop has completed
-**************************************************************************/
-static void ficlExitInner(FICL_VM *pVM)
-{
- vmThrow(pVM, VM_INNEREXIT);
-}
-
-
-/**************************************************************************
- d n e g a t e
-** DOUBLE ( d1 -- d2 )
-** d2 is the negation of d1.
-**************************************************************************/
-static void dnegate(FICL_VM *pVM)
-{
- DPINT i = i64Pop(pVM->pStack);
- i = m64Negate(i);
- i64Push(pVM->pStack, i);
-
- return;
-}
-
-
-#if 0
-/**************************************************************************
-
-**
-**************************************************************************/
-static void funcname(FICL_VM *pVM)
-{
- IGNORE(pVM);
- return;
-}
-
-
-#endif
-/**************************************************************************
- f i c l W o r d C l a s s i f y
-** This public function helps to classify word types for SEE
-** and the deugger in tools.c. Given an pointer to a word, it returns
-** a member of WOR
-**************************************************************************/
-WORDKIND ficlWordClassify(FICL_WORD *pFW)
-{
- typedef struct
- {
- WORDKIND kind;
- FICL_CODE code;
- } CODEtoKIND;
-
- static CODEtoKIND codeMap[] =
- {
- {BRANCH, branchParen},
- {COLON, colonParen},
- {CONSTANT, constantParen},
- {CREATE, createParen},
- {DO, doParen},
- {DOES, doDoes},
- {IF, ifParen},
- {LITERAL, literalParen},
- {LOOP, loopParen},
- {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;
-}
-
-
-/**************************************************************************
- 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, "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);
- 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, "environment?", environmentQ,FW_DEFAULT);
- dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT);
- dictAppendWord(dp, "execute", execute, FW_DEFAULT);
- dictAppendWord(dp, "exit", exitCoIm, 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, "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);
- /* case of endof endcase */
- 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
-
- /*
- ** 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->pIfParen =
- dictAppendWord(dp, "(if)", ifParen, 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);
- 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;
-}
-