ref: 7e8060a09c49aabd3a65154d30639456c7326053
parent: 1ecc984e97566569a88c1bd670192fd550e4b789
author: jsadler <jsadler@ficl.sf.net>
date: Wed Apr 25 14:00:35 CDT 2001
version 2.05
--- a/ReadMe.txt
+++ b/ReadMe.txt
@@ -1,26 +1,74 @@
-Coming up:
-Web server scripting extension (GoAhead port)
-rel 2.05 -- August 2000
-- Step debugger
-- *** HTML documentation extensively revised ***
-- Incorporated Alpha (64 bit) patches from the freeBSD team.
+rel 2.05 -- April 2001
+
+This is a transitional release, but it adds a lot of new features.
+Ficl 3.0 will change the API to allow multiple concurrent FICL_SYSTEMs.
+This involves the addition of a single parameter to several functions
+(the parameter is a pointer to a FICL_SYSTEM).
+
+* Thanks to everyone who contributed fixes and features for this release! Especially
+* Guy Carver, Orjan Gustafson, Larry Hastings, Daniel Sobral, and Reuben Thomas.
+
+- HTML documentation extensively revised
+- Simple source debugger -- see tools.c
+- The text interpreter is now extensible - this is accomplished through the use
+ of ficlAddParseStep. FICL_MAX_PARSE_STEPS limits the number of parse steps
+ (default: 8). You can write a precompiled parse step (see ficlParseNumber) and
+ append it to the chain, or you can write one in ficl and use ADD-PARSE-STEP
+ to append it. Default parse steps are initialized in ficlInitSystem. You can list
+ the parse steps with parse-order ( -- ).
+- There is now a FICL_SYSTEM structure. This is a transitional release - version 3.0
+ will alter several API prototypes to take this as a parameter, allowing multiple
+ systems per process (and therefore multiple dictionaries). For those who use ficl
+ under a virtual memory O/S like Linux or Win NT, you can just create multiple ficl
+ processes (not threads) instead and save youself the wait.
+- Fixes for improved command line operation in testmain.c (Larry Hastings)
+- Numerous extensions to OO facility, including a new allot methods, ability
+ to catch method invocations (thanks to Daniel Sobral again)
+- Incorporated Alpha (64 bit) patches contributed by Daniel Sobral and the freeBSD team
+ Ficl is now 64 bit friendly! UNS32 is now FICL_UNS.
- Split SEARCH and SEARCH EXT words from words.c to search.c
- ABORT" now complies with the ANS (-2 THROWs)
-- 2LOCALS defined in jhlocal syntax now lose the first
- '2' in their names. See ficl_loc.html
+- 2LOCALS defined in jhlocal syntax now lose the "2:" in their names. See ficl_loc.html
+- Floating point support contributed by Guy Carver (Enable FICL_WANT_FLOAT in sysdep.h).
+- Win32 vtable model for objects (Guy Carver)
+- Win32 dll load/call suport (Larry Hastings)
+- Prefix support (Larry Hastings) (prefix.c prefix.fr FICL_EXTENDED_PREFIX) makes it
+ easy to extend the parser to recignize prefixes like 0x and act on them. Use show-prefixes
+ to see what's defined.
+- Cleaned up initialization sequence so that it's all in ficlInitSystem
-ficl words
-- ABORT" works correctly (oops)
-- REFILL works correctly
+Ficl words
+- ABORT" and REFILL fixed (thanks to Daniel Sobral)
- ANS CORE EXT words: 2r@ 2r> 2>r
+- Numerous ANS FLOAT and FLOAT EXT words (Larry Carver) -- see float.c
- ANS DOUBLE words: 2variable
- .S now displays all stack entries on one line, like a stack comment
-- wid-get-name given a wid, returns the address and count of its name. If no name, count is 0
-- wid-set-name set optional wid name pointer to the \0 terminated string address specified.
-- ficl-named-wordlist creates a ficl-wordlist and names it
-- last-word returns the xt of the word being defined or most recently defined.
+- wid-get-name ( -- c-adr u )
+ given a wid, returns the address and count of its name. If no name, count is 0
+- wid-set-name ( c-addr -- )
+ set optional wid name pointer to the \0 terminated string address specified.
+- ficl-named-wordlist ( -- wid ) "name"
+ creates a ficl-wordlist and names it
+- last-word ( -- xt )
+ returns the xt of the word being defined or most recently defined.
- q@ and q! operate on quadbyte quantities for 64 bit friendliness
+- add-parse-step ( xt -- )
+ Allows the parser to be extended. To create a parse step, define a word that
+ consumes a counted string from the stack and returns (minimally) a flag. Once installed in the
+ parse chain, this word will be called when the previous steps in the chain have failed to
+ parse the current token. Upon entry, the token's address and count will be on the stack.
+ If the parse step succeeds in parsing the token, it should apply whatever semantics the token
+ requires, then push FICL_TRUE on the stack. If it fails, the step should push FICL_FALSE.
+ To install the parse step, use add-parse-step passing it the xt of the new parse step.
+ Add-parse-step may fail silently if the parse list is full. You can confirm success using
+ parse-order ( -- ).
+- (parse-step) ( c-addr u -- ??? flag )
+ Runtime support for precompiled parse steps (see ficl.c: AddPrecompiledParseStep)
+- env-constant ( u -- ) "name"
+- env-2constant ( ud -- ) "name"
+ set environment values from Ficl. Use .env ( -- ) to view defined symbols
+ in the environment, or environment? (CORE) to find their values.
softcore.fr words
- ORDER now lists wordlists by name
@@ -28,15 +76,19 @@
- brand-wordlist
New OO stuff
+- Double width locals - prefix a local name with "2:" and it is automatically
+ created as a double cell local. Handy for objects. Example:
+ : method { 2:this -- } this --> do-nothing ;- Class methods ALLOT and ALLOT-ARRAY
- METHOD define method names globally
- my=> early bind a method call to "this" class
- my=[ ] early bind a string of method calls to "this" class and obj members
- c-> late bind method invocation with CATCH
-- metaclass method resume-class and instance word suspend-class to create
+- metaclass method RESUME-CLASS and instance word SUSPEND-CLASS to create
mutually referring classes. Example in string.fr
- early binding words are now in the instance-vars wordlist,
not visible unless defining a class.
+- string.fr enhanced for dynamic allocation and resize of string contents
rel 2.04 -- May 2000
--- a/dict.c
+++ b/dict.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - dictionary methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: dict.c,v 1.6 2000/06/17 14:43:44 jsadler Exp $
+** $Id: dict.c,v 1.7 2001/04/25 18:59:19 jsadler Exp $
*******************************************************************/
/*
** This file implements the dictionary -- FICL's model of
@@ -16,6 +16,35 @@
**
** 29 jun 1998 (sadler) added variable sized hash table support
*/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <stdio.h> /* sprintf */
@@ -346,7 +375,7 @@
pDict = ficlMalloc(nAlloc);
assert(pDict);
- memset(pDict, 0, sizeof (FICL_DICT));
+
pDict->size = nCells;
dictEmpty(pDict, nHash);
return pDict;
@@ -354,6 +383,25 @@
/**************************************************************************
+ d i c t C r e a t e W o r d l i s t
+** Create and initialize an anonymous wordlist
+**************************************************************************/
+FICL_HASH *dictCreateWordlist(FICL_DICT *dp, int nBuckets)
+{+ FICL_HASH *pHash;
+
+ dictAlign(dp);
+ pHash = (FICL_HASH *)dp->here;
+ dictAllot(dp, sizeof (FICL_HASH)
+ + (nBuckets-1) * sizeof (FICL_WORD *));
+
+ pHash->size = nBuckets;
+ hashReset(pHash);
+ return pHash;
+}
+
+
+/**************************************************************************
d i c t D e l e t e
** Free all memory allocated for the given dictionary
**************************************************************************/
@@ -670,7 +718,8 @@
if (si.count == 0)
return 0;
- for (cp = (UNS8 *)si.cp; *cp && si.count; cp++, si.count--)
+ /* changed to run without errors under Purify -- lch */
+ for (cp = (UNS8 *)si.cp; si.count && *cp; cp++, si.count--)
{code = (UNS16)((code << 4) + tolower(*cp));
shift = (UNS16)(code & 0xf000);
@@ -725,7 +774,7 @@
**************************************************************************/
FICL_WORD *hashLookup(FICL_HASH *pHash, STRINGINFO si, UNS16 hashCode)
{- FICL_COUNT nCmp = (FICL_COUNT)si.count;
+ FICL_UNS nCmp = si.count;
FICL_WORD *pFW;
UNS16 hashIdx;
@@ -770,7 +819,7 @@
}
pHash->link = NULL;
- pHash->name = NULL;
+ pHash->name = NULL;
return;
}
--- a/doc/ficl.html
+++ b/doc/ficl.html
@@ -4,62 +4,16 @@
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="Author" content="john sadler">
<meta name="Description" content="the coolest embedded scripting language ever">
- <meta name="GENERATOR" content="Mozilla/4.7 [en]C-CCK-MCD {Sony} (WinNT; U) [Netscape]">- <title>Ficl Documentation</title>
+ <title>Ficl - Embedded Scripting</title>
</head>
<body>
<link REL="SHORTCUT ICON" href="ficl.ico">
-<h1>
-<b>Ficl Documentation</b></h1>
+<h1><b>Ficl Documentation</b></h1>
-<table BORDER=0 CELLSPACING=3 WIDTH="640" >
-<tr>
-<td><b>Forth Inspired Command Language </b></td>
+<script language="javascript" src="ficlheader.js"></script>
-<td ROWSPAN="4"><img SRC="ficl_logo.jpg" height=64 width=64></td>
+<h2>Contents</h2>
-<td ROWSPAN="4"><a href="http://www.links2go.net/topic/Forth"><img SRC="skey.gif" ALT="Key Resource" BORDER=0 height=81 width=81></a></td>
-</tr>
-
-<tr>
-<td><b>Author: John Sadler (<a href="mailto:john_sadler@alum.mit.edu">john_sadler@alum.mit.edu</a>)</b></td>
-</tr>
-
-<tr>
-<td><b>Created: 19 July 1997 </b></td>
-</tr>
-
-<tr>
-<td><b>Revision 2.05: October 2000</b></td>
-</tr>
-
-<tr>
-<td COLSPAN="3"><!-- Begin ListBot Code --><form method="post" action="http://www.listbot.com/cgi-bin/subscriber">
-<table BORDER=0 >
-<tr>
-<td COLSPAN="2">Join the ficl mailing list - enter your email address here
-to be notified of new releases: </td>
-</tr>
-
-<tr>
-<td><input type=text name="e_mail"><input type=hidden name="list_id" value="ficl"><input type=hidden name="Act" value="subscribe_list"></td>
-
-<td><input type=image src="http://www.listbot.com/subscribe_button.gif" border=0
- width=88 height=31 alt="Click here to join our mailing list!"></td>
-</tr>
-
-<tr>
-<td COLSPAN="2"><font face="arial"><font size=-2><a href="http://www.listbot.com/" target="_top">Powered
-by ListBot</a></font></font></td>
-</tr>
-</table>
-</form><!-- End ListBot Code --></td>
-</tr>
-</table>
-
-<h2>
-Contents</h2>
-
<ul>
<li>
<font size=+1><a href="ficl_rel.html">Release notes</a></font></li>
@@ -71,11 +25,11 @@
<font size=+1><a href="#download">Download</a></font></li>
<li>
-<font size=+1><a href="#links">References</a></font></li>
+<font size=+1><a href="#links">Tutorials and References</a></font></li>
<li>
-<font color="#000000"><font size=+1><a href="#includesficl">Some software
-that incorporates Ficl</a></font></font></li>
+<font size=+1><a href="#includesficl">Some software
+that incorporates Ficl</a></font></li>
<li>
<font size=+1><a href="#lawyerbait">Disclaimer & License</a></font></li>
@@ -130,14 +84,15 @@
<tr>
<td>
<h1>
-<a NAME="whatis"></a>What is ficl?</h1>
-<font size=+1>Ficl is a complete programming language interpreter designed
+<a NAME="whatis"></a>What is ficl?
+</h1>
+Ficl is a complete programming language interpreter designed
to be embedded into other systems as a command/macro/development prototype
language. Ficl provides object extensions that can be used to wrap methods
and structures of the host system without altering them. The syntax is
based on ANS Forth and the code is Standard C. See below for examples of
<a href="#includesficl">software
-that includes ficl</a>. Ficl stands for "Forth inspired command language". </font></td>
+that includes ficl</a>. Ficl stands for "Forth inspired command language". </td>
</tr>
<tr>
@@ -190,20 +145,23 @@
<ul>
<li>
-<b><a href="ftp://ftp.taygeta.com/pub/Forth/Compilers/native/misc/ficl205/ficl205.zip">Download
-ficl (latest release)</a></b></li>
+<b><a href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download
+ficl (latest release)</a></b>
+</li>
<li>
-<b><a href="ftp://ftp.taygeta.com/pub/Forth/Compilers/native/misc/ficl205/ficlwin.zip">Download
-ficlWin</a> (not for resale. please contact me for resale license arrangements)</b></li>
+<b><a href="http://sourceforge.net/project/showfiles.php?group_id=24441">Download
+ficlWin</a> (not for resale. please contact me for resale license arrangements)</b>
+</li>
</ul>
<h2>
-<a NAME="links"></a>More information on Ficl and Forth</h2>
+<a NAME="links"></a>More information on Ficl and Forth
+</h2>
<ul>
<li>
-<a href="http://www.taygeta.com/ficl.html">Web home of Ficl</a></li>
+<a href="http://ficl.sourceforge.net">Web home of Ficl</a></li>
<li>
<a href="ficlddj.pdf">Manuscript of Ficl article for January 1999 Dr. Dobb's
@@ -214,13 +172,8 @@
Ficl</a></li>
<li>
-<a href="http://www.taygeta.com/forthlit.html">Forth literature index on
-Taygeta</a></li>
-
-<ul>
-<li>
<a href="http://www.taygeta.com/forth_intro/stackflo.html">An Introduction
-to Forth using Stack Flow</a></li>
+to Forth using Stack Flow</a> (start here if you're new to Forth)</li>
<li>
<a href="http://www.softsynth.com/pforth/pf_tut.htm">Phil Burk's Forth
@@ -227,12 +180,21 @@
Tutorial</a></li>
<li>
-<a href="http://www.taygeta.com/forth/dpans.html">Draft Proposed American
-National Standard for Forth</a></li>
-</ul>
+<a href="http://www.complang.tuwien.ac.at/forth/threaded-code.html">Anton Ertl's description of Threaded Code</a>
+</li>
<li>
-<a href="http://www.forth.org">Forth Interest Group</a></li>
+<a href="http://ficl.sourceforge.net/dpans/dpans.html">Draft Proposed American
+National Standard for Forth</a> (quite readable, actually)
+</li>
+
+<li>
+<a href="http://www.taygeta.com/forthlit.html">Forth literature index on
+Taygeta</a></li>
+
+<li>
+<a href="http://www.forth.org">Forth Interest Group</a>
+</li>
</ul>
<h2>
@@ -240,19 +202,32 @@
<ul>
<li>
-<a href="http://www.freebsd.org/">FreeBSD</a> boot loader</li>
+<a href="http://www.freebsd.org/">FreeBSD</a> boot loader (Daniel Sobral, Jordan Hubbard)</li>
<li>
-<a href="http://www.pagesz.net/~sessoms/debuffer/">Palm Pilot Debuffer</a>
-(Eric Sessoms)</li>
+<a href="http://www.chipcenter.com/networking/images/prod/prod158a.pdf">SwitchCore</a>
+Gigabit Ethernet switches (�rjan Gustavsson )</li>
<li>
-<a href="http://www.swcp.com/~jchavez/osmond.html">Mac PC Board Layout
+<a href="http://debuffer.sourceforge.net/">Palm Pilot Debuffer</a>
+(Eric Sessoms) Also see ficlx, a C++ interface to ficl, on the same site</li>
+
+<li>
+<a href="http://www.swcp.com/~jchavez/osmond.html">Osmond PC Board Layout
tool</a> (J Chavez)</li>
<li>
<a href="http://www.netcomsystems.com">NetCom Systems</a> ML7710 (Martin
Usher)</li>
+<li>
+<a href="http://www.parview.com/ds/homepage.html">ParView</a> GPS system
+</li>
+<li>
+<a href="http://www.thekompany.com/products/powerplant/software/Languages/Embedded.php3">PowerPlant Software</a> Development Environment for Linux
+</li>
+<li>
+<a href="mailto:john_sadler@alum.mit.edu"><i>Your Product Name Here!!!</i></a>
+</li>
</ul>
<hr>
@@ -261,24 +236,23 @@
<td>
<h2>
<a NAME="lawyerbait"></a>DISCLAIMER OF WARRANTY and LICENSE</h2>
-<i>Ficl is freeware. Use it in any way that you like, with the understanding
-that the code is not supported.</i>
-<p>Any third party may reproduce, distribute, or modify the ficl software
-code or any derivative works thereof without any compensation or license,
-provided that the original author information and this disclaimer text
-are retained in the source code files. The ficl software code is provided
-on an "as is" basis without warranty of any kind, including, without limitation,
-the implied warranties of merchantability and fitness for a particular
-purpose and their equivalents under the laws of any jurisdiction.
-<p>The FiclWin distribution, a derivative work of the ficl source code,
-is hereby licensed for unrestricted non-commercial use under the ficl license
-provided the user notifies the author (John Sadler) in writing or by electronic
-mail or their intended use of the FiclWin sources. You may freely redistribute
-the FiclWin distribution provided it contains this notice and adheres to
-all other provisions of this license.
-<p>Reselling the FiclWin source code, executable, or works derived from
-the FiclWin source code is prohibited under this license. Please contact
-me directly in order to discuss license terms for commercial use and distribution.
+<p>Ficl is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.</p>
+
+<p>The ficl software code is provided on an "as is" basis without
+warranty of any kind, including, without limitation, the implied
+warranties of merchantability and fitness for a particular purpose
+and their equivalents under the laws of any jurisdiction.
+See the <a HREF="http://www.fsf.org/copyleft/lesser.html">
+GNU Lesser General Public License</a> for more details.</p>
+
+<p>Any third party may reproduce, distribute, or modify the ficl
+software code or any derivative works thereof without any
+compensation, provided that the author information
+and license text are retained in the source code files.</p>
+
<p>I am interested in hearing from anyone who uses ficl. If you have a
problem, a success story, a defect, an enhancement request, or if you would
like to contribute to the ficl release, please <a href="mailto:john_sadler@alum.mit.edu">send
@@ -295,9 +269,13 @@
<ul>
<li>
-Code is written in ANSI C for portability. </li>
+Simple to integrate into existing systems: the sample implementation requires
+three Ficl function calls (see the example program in testmain.c).</li>
<li>
+Written in ANSI C for portability. </li>
+
+<li>
Standard: Implements the ANS Forth CORE word set, part of the CORE EXT
word set, SEARCH and SEARCH EXT, TOOLS and part of TOOLS EXT, LOCAL and
LOCAL EXT, EXCEPTION, MEMORY, and various extras.</li>
@@ -309,12 +287,13 @@
you're familiar with Forth)</li>
<li>
-Ficl and C can interact in two ways: Ficl can wrap C code, and C functions
+Ficl and C/C++ can interact in two ways: Ficl can wrap C code, and C functions
can invoke ficl code.</li>
<li>
-Ficl code is thread safe and re-entrant: All Ficl VMs share one system
-dictionary; each Ficl virtual machine has an otherwise complete state,
+Ficl code is thread safe and re-entrant: All Ficl Virtual Machines share one system
+dictionary (version 3.0 will permit multiple dictionaries);
+each Ficl Virtual Machine has an otherwise complete state,
and each can be bound to a separate I/O channel (or none at all). An optional
function called ficlLockDictionary() can control exclusive dictionary access.
This function is stubbed out by default (See FICL_MULTITHREAD in sysdep.h).
@@ -330,25 +309,19 @@
from multiple threads.</font></li>
<li>
-Simple incorporation into existing systems: the sample implementation requires
-three Ficl function calls (see the example program in testmain.c).</li>
-
-<li>
-ROM able: Ficl is designed to work in RAM based and ROM code / RAM data
+ROMable: Ficl is designed to work in RAM based and ROM code / RAM data
environments. It does require somewhat more memory than a pure ROM implementation
because it builds its system dictionary in RAM at startup time.</li>
<li>
-Written an ANSI C to be as simple as I can make it to understand, support,
+Written in ANSI C to be as simple as I can make it to understand, support,
debug, and port. Compiles without complaint at /Az /W4 (require ANSI C,
-max. warnings) under Microsoft VC++</li>
+max. warnings) under Microsoft VC++. Ports to several other toolchains and operating systems
+(notably FreeBSD and Linux flavors) exist.</li>
<li>
Does full 32 bit math (but you need to implement two mixed precision math
primitives (see sysdep.c))</li>
-
-<li>
-Type 1 indirect threaded interpreter</li>
</ul>
</td>
</tr>
@@ -366,9 +339,8 @@
For example, <tt>INT16</tt> is a <tt>short</tt> on some compilers and an
<tt>int</tt>
on others. Check the default <tt>CELL</tt> alignment controlled by <tt>FICL_ALIGN</tt>.
-If necessary, add new definitions of <tt>ficlMalloc, ficlFree, ficlRealloc,
-ficlLockDictionary</tt>, and <tt>ficlTextOut</tt> to work with your operating
-system. Finally, use
+If necessary, add new definitions of <tt>ficlMalloc, ficlFree, ficlRealloc</tt>,
+and <tt>ficlTextOut</tt> to work with your operating system. Finally, use
<tt>testmain.c</tt> as a guide to installing the ficl
system and one or more virtual machines into your code. You do not need
to include <tt>testmain.c</tt> in your build.
@@ -922,12 +894,8 @@
Pushes the xt address of the most recently defined word. This applies to
colon definitions, constants, variables, and words that use <tt>create</tt>.
You can print the name of the most recently defined word with </dd>
+<b><tt>last-word >name type</tt> </b>
-<dl>
-<dd>
-<b><tt>last-word >name type</tt> </b></dd>
-</dl>
-
<dt>
<tt>parse-word ( <spaces>name -- c-addr u )</tt></dt>
@@ -971,7 +939,7 @@
</dl>
<h3>
-<a NAME="exficlwin"></a>FiclWin Extras (defined in testmain.c)</h3>
+<a NAME="exficlwin"></a>Extra words defined in testmain.c (Win32 and POSIX versions)</h3>
<dl>
<dt>
@@ -1031,7 +999,7 @@
</dl>
<h3>
-FiclWin Exclusives (no source provided)</h3>
+Words defined in FiclWin only</h3>
<dl>
<dt>
--- a/doc/ficl_debug.html
+++ b/doc/ficl_debug.html
@@ -11,27 +11,8 @@
<h1>
<b>Ficl Debugger</b></h1>
-<table BORDER=0 CELLSPACING=3 WIDTH="640" >
-<tr>
-<td><b>Forth Inspired Command Language </b></td>
+<script language="javascript" src="ficlheader.js"></script>
-<td ROWSPAN="4"><img SRC="ficl_logo.jpg" height=64 width=64></td>
-
-<td ROWSPAN="4"><a href="http://www.links2go.net/topic/Forth"><img SRC="skey.gif" ALT="Key Resource" BORDER=0 height=81 width=81></a></td>
-</tr>
-
-<tr>
-<td><b>Author: John Sadler (<a href="mailto:john_sadler@alum.mit.edu">john_sadler@alum.mit.edu</a>)</b></td>
-</tr>
-
-<tr>
-<td><b>Created: 19 July 1997 </b></td>
-</tr>
-
-<tr>
-<td><b>Revision 2.05: August 2000</b></td>
-</tr>
-</table>
<br>
<table COLS=1 WIDTH="650" >
--- a/doc/ficl_loc.html
+++ b/doc/ficl_loc.html
@@ -12,37 +12,21 @@
<h1>
<b>Local Variables in Ficl</b></h1>
-<table BORDER=0 CELLSPACING=3 WIDTH="600" >
-<tr>
-<td><b>Forth Inspired Command Language </b></td>
-<td ROWSPAN="4"><img SRC="ficl_logo.jpg" height=64 width=64></td>
-</tr>
+<script language="javascript" src="ficlheader.js"></script>
-<tr>
-<td><b>Author: John Sadler (<a href="mailto:john_sadler@alum.mit.edu">john_sadler@alum.mit.edu</a>)</b></td>
-</tr>
-<tr>
-<td><b>Created: 19 July 1997 </b></td>
-</tr>
-
-<tr>
-<td><b>Revision 2.04: 20 May 2000</b></td>
-</tr>
-</table>
-
<table BORDER=0 CELLSPACING=3 COLS=1 WIDTH="675" >
<tr>
<td>
<h2>
<a NAME="locals"></a>Local Variables</h2>
-Locally scoped variables came late to Forth. Purists seem to feel that
-experienced Forth programmers can write supportable code using only anonymous
+Named locally scoped variables came late to Forth. Purists feel that experienced
+Forth programmers can (and should) write supportable code using only anonymous
stack variables and good factoring, but they complain that novices use
global variables too much. Local variables cost little in terms of code
size and execution speed, and are very convenient for OO programming, where
-stack effects are more complex. I use them a lot.
+stack effects are more complex. I use them a lot (maybe I'm a weenie).
<br><a href="http://www.taygeta.com/forth/dpans13.htm">Please refer to
the Standard</a> for more information on local variables.
<h2>
@@ -66,7 +50,7 @@
one cell. Local variable names prefixed with the character '2' in the declaration
are double-cell locals. They behave the same as single cell locals in all
other respects. I use 2locals quite a bit in Ficl's OO classes, because
-objects in Ficl are require two cells on the stack. You can modify the
+objects in Ficl require two cells on the stack. You can modify the
value of a double cell local with <tt><a href="http://www.taygeta.com/forth/dpans13.htm#13.6.1.2295">TO</a></tt>
the same as you would a single cell local.
<br>Following are some examples to illustrate usage (they are not intended
--- a/doc/ficl_oop.html
+++ b/doc/ficl_oop.html
@@ -12,26 +12,10 @@
<h1>
<b>Object Oriented Programming in ficl</b></h1>
-<table BORDER=0 CELLSPACING=3 WIDTH="600" >
-<tr>
-<td><b>Forth Inspired Command Language </b></td>
-<td ROWSPAN="4"><img SRC="ficl_logo.jpg" height=64 width=64></td>
-</tr>
+<script language="javascript" src="ficlheader.js"></script>
-<tr>
-<td><b>Author: John Sadler (<a href="mailto:john_sadler@alum.mit.edu">john_sadler@alum.mit.edu</a>)</b></td>
-</tr>
-<tr>
-<td><b>Created: 6 June 2000</b></td>
-</tr>
-
-<tr>
-<td><b>Revised: </b></td>
-</tr>
-</table>
-
<h2>
Contents</h2>
@@ -68,7 +52,7 @@
<a NAME="objects"></a>Object Oriented Programming in ficl</h2>
<h3>
-Review of <a href="http://www.whatis.com/oop.htm">OO</a> ideas</h3>
+Review of <a href="http://whatis.techtarget.com/definition/0,289893,sid9_gci212681,00.html">OO</a> ideas</h3>
Click <a href="oo_in_c.html#review">here</a> for a short review of OO ideas,
terms, and implementations in other languages, or <a href="http://www.soft-design.com/softinfo/objects.html">here</a>
for an introduction to the terms and principles of Object Oriented Programming
--- a/doc/ficl_rel.html
+++ b/doc/ficl_rel.html
@@ -11,25 +11,9 @@
<h1>
<b>Ficl Release Notes</b></h1>
-<table BORDER=0 CELLSPACING=3 WIDTH="600" >
-<tr>
-<td><b>Forth Inspired Command Language </b></td>
-<td ROWSPAN="4"><img SRC="ficl_logo.jpg" height=64 width=64></td>
-</tr>
+<script language="javascript" src="ficlheader.js"></script>
-<tr>
-<td><b>Author: John Sadler (<a href="mailto:john_sadler@alum.mit.edu">john_sadler@alum.mit.edu</a>)</b></td>
-</tr>
-
-<tr>
-<td><b>Created: 19 July 1997 </b></td>
-</tr>
-
-<tr>
-<td></td>
-</tr>
-</table>
<br>
<table BORDER=0 CELLPADDING=3 COLS=1 WIDTH="675" >
--- a/doc/oo_in_c.html
+++ b/doc/oo_in_c.html
@@ -2,8 +2,6 @@
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <meta name="Generator" content="Microsoft Word 97">
- <meta name="GENERATOR" content="Mozilla/4.73 [en] (Win98; U) [Netscape]">
<title>Object Oriented Idioms in C</title>
</head>
<body>
--- a/ficl.c
+++ b/ficl.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - external interface
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: ficl.c,v 1.8 2000/10/01 23:50:35 jsadler Exp $
+** $Id: ficl.c,v 1.9 2001/04/25 18:59:56 jsadler Exp $
*******************************************************************/
/*
** This is an ANS Forth interpreter written in C.
@@ -15,11 +15,40 @@
** 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.
+** text block, so the data pump is somewhere in external code in the
+** style of TCL.
**
** Code is written in ANSI C for portability.
*/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <string.h>
@@ -27,11 +56,6 @@
/*
-** Local prototypes
-*/
-
-
-/*
** System statics
** The system builds a global dictionary during its start
** sequence. This is shared by all interpreter instances.
@@ -42,12 +66,7 @@
** but you can insert one: #define FICL_MULTITHREAD 1
** and supply your own version of ficlLockDictionary.
*/
-static FICL_DICT *dp = NULL;
-static FICL_DICT *envp = NULL;
-#if FICL_WANT_LOCALS
-static FICL_DICT *localp = NULL;
-#endif
-static FICL_VM *vmList = NULL;
+static FICL_SYSTEM *pSys = NULL;
static int defaultStack = FICL_DEFAULT_STACK;
static int defaultDict = FICL_DEFAULT_DICT;
@@ -66,25 +85,20 @@
**************************************************************************/
void ficlInitSystem(int nDictCells)
{- if (dp)
- dictDelete(dp);
+ pSys = ficlMalloc(sizeof (FICL_SYSTEM));
+ assert(pSys);
- if (envp)
- dictDelete(envp);
+ memset(pSys, 0, sizeof (FICL_SYSTEM));
-#if FICL_WANT_LOCALS
- if (localp)
- dictDelete(localp);
-#endif
-
if (nDictCells <= 0)
nDictCells = defaultDict;
- dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
- dp->pForthWords->name = "forth-wordlist";
- envp = dictCreate( (unsigned)FICL_DEFAULT_ENV);
- envp->pForthWords->name = "environment";
+ pSys->dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
+ pSys->dp->pForthWords->name = "forth-wordlist";
+ pSys->envp = dictCreate((unsigned)FICL_DEFAULT_ENV);
+ pSys->envp->pForthWords->name = "environment";
+
#if FICL_WANT_LOCALS
/*
** The locals dictionary is only searched while compiling,
@@ -93,33 +107,119 @@
** The need to balance search speed with the cost of the empty
** operation led me to select a single-threaded list...
*/
- localp = dictCreate( (unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
+ pSys->localp = dictCreate((unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
#endif
- ficlCompileCore(dp);
+ /*
+ ** Establish the parse order. Note that prefixes precede numbers -
+ ** this allows constructs like "0b101010" which would parse as a
+ ** valid hex value otherwise.
+ */
+ ficlCompilePrefix(pSys);
+ ficlAddPrecompiledParseStep(pSys, "number?", ficlParseNumber);
+ /*
+ ** Build the precompiled dictionary and load softwords. We need a temporary
+ ** VM to do this - ficlNewVM links one to the head of the system VM list.
+ ** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words.
+ */
+ ficlCompileCore(pSys);
+#if FICL_WANT_FLOAT
+ ficlCompileFloat(pSys);
+#endif
+
+#if FICL_PLATFORM_EXTEND
+ ficlCompilePlatform(pSys);
+#endif
+
+ /*
+ ** Now we can create a VM to compile the softwords. Note that the VM initialization
+ ** code needs to be able to find "interpret" in the dictionary in order to
+ ** succeed, so as presently constructed ficlCompileCore has to finish before
+ ** a VM can be created successfully.
+ */
+ ficlNewVM();
+ ficlCompileSoftCore(pSys);
+ ficlFreeVM(pSys->vmList);
+
+
return;
}
/**************************************************************************
+ f i c l A d d P a r s e S t e p
+** Appends a parse step function to the end of the parse list (see
+** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
+** nonzero if there's no more room in the list.
+**************************************************************************/
+int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW)
+{+ int i;
+ for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
+ {+ if (pSys->parseList[i] == NULL)
+ {+ pSys->parseList[i] = pFW;
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+
+/*
+** Compile a word into the dictionary that invokes the specified FICL_PARSE_STEP
+** function. It is up to the user (as usual in Forth) to make sure the stack
+** preconditions are valid (there needs to be a counted string on top of the stack)
+** before using the resulting word.
+*/
+void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep)
+{+ FICL_DICT *dp = pSys->dp;
+ FICL_WORD *pFW = dictAppendWord(dp, name, parseStepParen, FW_DEFAULT);
+ dictAppendCell(dp, LVALUEtoCELL(pStep));
+ ficlAddParseStep(pSys, pFW);
+}
+
+
+/*
+** This word lists the parse steps in order
+*/
+void ficlListParseSteps(FICL_VM *pVM)
+{+ int i;
+ FICL_SYSTEM *pSys = pVM->pSys;
+ assert(pSys);
+
+ vmTextOut(pVM, "Parse steps:", 1);
+ vmTextOut(pVM, "lookup", 1);
+
+ for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
+ {+ if (pSys->parseList[i] != NULL)
+ {+ vmTextOut(pVM, pSys->parseList[i]->name, 1);
+ }
+ else break;
+ }
+ return;
+}
+
+
+/**************************************************************************
f i c l N e w V M
** Create a new virtual machine and link it into the system list
-** of VMs for later cleanup by ficlTermSystem. If this is the first
-** VM to be created, use it to compile the words in softcore.c
+** of VMs for later cleanup by ficlTermSystem.
**************************************************************************/
FICL_VM *ficlNewVM(void)
{FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
- pVM->link = vmList;
+ pVM->link = pSys->vmList;
+ pVM->pSys = pSys;
- /*
- ** Borrow the first vm to build the soft words in softcore.c
- */
- if (vmList == NULL)
- ficlCompileSoftCore(pVM);
-
- vmList = pVM;
+ pSys->vmList = pVM;
return pVM;
}
@@ -133,26 +233,26 @@
**************************************************************************/
void ficlFreeVM(FICL_VM *pVM)
{- FICL_VM *pList = vmList;
+ FICL_VM *pList = pSys->vmList;
- assert(pVM != 0);
+ assert(pVM != 0);
- if (vmList == pVM)
- {- vmList = vmList->link;
- }
- else for (pList; pList != 0; pList = pList->link)
- {- if (pList->link == pVM)
- {- pList->link = pVM->link;
- break;
- }
- }
+ if (pSys->vmList == pVM)
+ {+ pSys->vmList = pSys->vmList->link;
+ }
+ else for (; pList != NULL; pList = pList->link)
+ {+ if (pList->link == pVM)
+ {+ pList->link = pVM->link;
+ break;
+ }
+ }
- if (pList)
- vmDelete(pVM);
- return;
+ if (pList)
+ vmDelete(pVM);
+ return;
}
@@ -173,14 +273,14 @@
**************************************************************************/
int ficlBuild(char *name, FICL_CODE code, char flags)
{- int err = ficlLockDictionary(TRUE);
- if (err) return err;
+ int err = ficlLockDictionary(TRUE);
+ if (err) return err;
- assert(dictCellsAvail(dp) > sizeof (FICL_WORD) / sizeof (CELL));
- dictAppendWord(dp, name, code, flags);
+ assert(dictCellsAvail(pSys->dp) > sizeof (FICL_WORD) / sizeof (CELL));
+ dictAppendWord(pSys->dp, name, code, flags);
- ficlLockDictionary(FALSE);
- return 0;
+ ficlLockDictionary(FALSE);
+ return 0;
}
@@ -209,7 +309,8 @@
int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
{- static FICL_WORD *pInterp[3] = {NULL, NULL, NULL};+ FICL_WORD **pInterp = pSys->pInterp;
+ FICL_DICT *dp = pSys->dp;
int except;
jmp_buf vmState;
@@ -267,7 +368,7 @@
case VM_USEREXIT:
case VM_INNEREXIT:
- case VM_BREAK:
+ case VM_BREAK:
break;
case VM_QUIT:
@@ -275,7 +376,7 @@
{dictAbortDefinition(dp);
#if FICL_WANT_LOCALS
- dictEmpty(localp, localp->pForthWords->size);
+ dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
#endif
}
vmQuit(pVM);
@@ -289,7 +390,7 @@
{dictAbortDefinition(dp);
#if FICL_WANT_LOCALS
- dictEmpty(localp, localp->pForthWords->size);
+ dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
#endif
}
dictResetSearchOrder(dp);
@@ -359,7 +460,7 @@
break;
case VM_INNEREXIT:
- case VM_BREAK:
+ case VM_BREAK:
break;
case VM_RESTART:
@@ -394,7 +495,7 @@
{STRINGINFO si;
SI_PSZ(si, name);
- return dictLookup(dp, si);
+ return dictLookup(pSys->dp, si);
}
@@ -404,7 +505,7 @@
**************************************************************************/
FICL_DICT *ficlGetDict(void)
{- return dp;
+ return pSys->dp;
}
@@ -414,7 +515,7 @@
**************************************************************************/
FICL_DICT *ficlGetEnv(void)
{- return envp;
+ return pSys->envp;
}
@@ -427,6 +528,7 @@
{STRINGINFO si;
FICL_WORD *pFW;
+ FICL_DICT *envp = pSys->envp;
SI_PSZ(si, name);
pFW = dictLookup(envp, si);
@@ -448,6 +550,7 @@
{FICL_WORD *pFW;
STRINGINFO si;
+ FICL_DICT *envp = pSys->envp;
SI_PSZ(si, name);
pFW = dictLookup(envp, si);
@@ -475,7 +578,7 @@
#if FICL_WANT_LOCALS
FICL_DICT *ficlGetLoc(void)
{- return localp;
+ return pSys->localp;
}
#endif
@@ -504,27 +607,29 @@
**************************************************************************/
void ficlTermSystem(void)
{- if (dp)
- dictDelete(dp);
- dp = NULL;
+ if (pSys->dp)
+ dictDelete(pSys->dp);
+ pSys->dp = NULL;
- if (envp)
- dictDelete(envp);
- envp = NULL;
+ if (pSys->envp)
+ dictDelete(pSys->envp);
+ pSys->envp = NULL;
#if FICL_WANT_LOCALS
- if (localp)
- dictDelete(localp);
- localp = NULL;
+ if (pSys->localp)
+ dictDelete(pSys->localp);
+ pSys->localp = NULL;
#endif
- while (vmList != NULL)
+ while (pSys->vmList != NULL)
{- FICL_VM *pVM = vmList;
- vmList = vmList->link;
+ FICL_VM *pVM = pSys->vmList;
+ pSys->vmList = pSys->vmList->link;
vmDelete(pVM);
}
+ ficlFree(pSys);
+ pSys = NULL;
return;
}
--- a/ficl.dsp
+++ b/ficl.dsp
@@ -96,10 +96,18 @@
# End Source File
# Begin Source File
+SOURCE=.\float.c
+# End Source File
+# Begin Source File
+
SOURCE=.\math64.c
# End Source File
# Begin Source File
+SOURCE=.\prefix.c
+# End Source File
+# Begin Source File
+
SOURCE=.\search.c
# End Source File
# Begin Source File
@@ -128,6 +136,19 @@
# End Source File
# Begin Source File
+SOURCE=.\win32.c
+
+!IF "$(CFG)" == "ficl - Win32 Release"
+
+!ELSEIF "$(CFG)" == "ficl - Win32 Debug"
+
+# ADD CPP /Ze
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
SOURCE=.\words.c
# End Source File
# End Group
@@ -184,6 +205,10 @@
# End Source File
# Begin Source File
+SOURCE=.\softwords\prefix.fr
+# End Source File
+# Begin Source File
+
SOURCE=.\softwords\softcore.bat
# End Source File
# Begin Source File
@@ -197,6 +222,38 @@
# Begin Source File
SOURCE=.\softwords\string.fr
+# End Source File
+# End Group
+# Begin Group "doc"
+
+# PROP Default_Filter ".html,.js"
+# Begin Source File
+
+SOURCE=..\doc\ficl.html
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ficl_debug.html
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ficl_loc.html
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ficl_oop.html
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ficl_rel.html
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ficlheader.js
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\oo_in_c.html
# End Source File
# End Group
# Begin Source File
--- a/ficl.h
+++ b/ficl.h
@@ -3,24 +3,32 @@
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: ficl.h,v 1.9 2000/10/01 23:50:36 jsadler Exp $
+** $Id: ficl.h,v 1.10 2001/04/25 19:00:01 jsadler Exp $
*******************************************************************/
/*
-** N O T I C E -- DISCLAIMER OF WARRANTY
+** 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
**
-** Ficl is freeware. Use it in any way that you like, with
-** the understanding that the code is supported on a "best effort"
-** basis only.
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
**
-** Any third party may reproduce, distribute, or modify the ficl
-** software code or any derivative works thereof without any
-** compensation or license, provided that the author information
-** and this disclaimer text are retained in the source code files.
** The ficl software code is provided on an "as is" basis without
** warranty of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular purpose
** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
** 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 (yay!), please
@@ -213,6 +221,8 @@
struct ficl_word;
struct vm;
struct ficl_dict;
+struct ficl_system;
+typedef struct ficl_system FICL_SYSTEM;
/*
** the Good Stuff starts here...
@@ -239,9 +249,13 @@
*/
typedef union _cell
{- FICL_INT i;
+ FICL_INT i;
FICL_UNS u;
- void *p;
+#if (FICL_WANT_FLOAT)
+ FICL_FLOAT f;
+#endif
+ void *p;
+ void (*fn)(void);
} CELL;
/*
@@ -299,7 +313,7 @@
{si.cp = pfs->text; si.count = pfs->count;}/*
-** Ficl uses a this little structure to hold the address of
+** 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.
@@ -349,7 +363,7 @@
void stackLink (FICL_STACK *pStack, int nCells);
void stackPick (FICL_STACK *pStack, int n);
CELL stackPop (FICL_STACK *pStack);
-void *stackPopPtr (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);
@@ -362,6 +376,38 @@
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, 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:
@@ -407,7 +453,7 @@
** ANS Forth requires that a word's name contain {1..31} characters.*/
#if !defined nFICLNAME
-#define nFICLNAME 31
+#define nFICLNAME 31
#endif
/*
@@ -415,6 +461,7 @@
*/
typedef struct vm
{+ FICL_SYSTEM *pSys; /* Which system this VM belongs to */
struct vm *link; /* Ficl keeps a VM list for simple teardown */
jmp_buf *pState; /* crude exception mechanism... */
OUTFUNC textOut; /* Output callback - see sysdep.c */
@@ -427,6 +474,9 @@
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 string, 0 if normal input */
TIB tib; /* address of incoming text string */
#if FICL_WANT_USER
@@ -559,6 +609,9 @@
** 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...
@@ -575,6 +628,7 @@
#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
@@ -598,7 +652,7 @@
char *strrev( char *string );
char *skipSpace(char *cp, char *end);
char *caseFold(char *cp);
-int strincmp(char *cp1, char *cp2, FICL_COUNT count);
+int strincmp(char *cp1, char *cp2, FICL_UNS count);
#if defined(_WIN32) && !FICL_MAIN
#pragma warning(default: 4273)
@@ -612,14 +666,14 @@
** just a pointer to a FICL_HASH in this implementation.
*/
#if !defined HASHSIZE /* Default size of hash table. For most uniform */
-#define HASHSIZE 127 /* performance, use a prime number! */
+#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;
+ char *name; /* optional pointer to \0 terminated wordlist name */
+ unsigned size; /* number of buckets in the hash */
FICL_WORD *table[1];
} FICL_HASH;
@@ -695,6 +749,7 @@
void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells);
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);
void dictHashSummary(FICL_VM *pVM);
@@ -710,7 +765,68 @@
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);
+
+/*
+** 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
+**
+** RESTRICTIONS: due to the use of static variables in words.c for compiling
+** comtrol structures faster, if you use multiple ficl systems these variables
+** will point into the most recently initialized dictionary - this is probably
+** not a problem provided the precompiled dictionaries are identical for
+** all systems.
+*/
+typedef struct ficl_system
+{+ FICL_SYSTEM *link;
+ FICL_WORD *parseList[FICL_MAX_PARSE_STEPS];
+ FICL_VM *vmList;
+ FICL_DICT *dp;
+ FICL_DICT *envp;
+#ifdef FICL_WANT_LOCALS
+ FICL_DICT *localp;
+#endif
+ FICL_WORD *pInterp[3];
+} FICL_SYSTEM;
+
+/*
** External interface to FICL...
*/
/*
@@ -827,10 +943,17 @@
** Builds the ANS CORE wordset into the dictionary - called by
** ficlInitSystem - no need to waste dict space by doing it again.
*/
-void ficlCompileCore(FICL_DICT *dp);
-void ficlCompileSearch(FICL_DICT *dp);
-void ficlCompileSoftCore(FICL_VM *pVM);
-void ficlCompileTools(FICL_DICT *dp);
+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);
+#if FICL_WANT_FLOAT
+void ficlCompileFloat(FICL_SYSTEM *pSys);
+#endif
+#if FICL_PLATFORM_EXTEND
+void ficlCompilePlatform(FICL_SYSTEM *pSys);
+#endif
/*
** from words.c...
@@ -837,27 +960,34 @@
*/
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_WORD *pFW);
+
/*
** The following supports SEE and the debugger.
*/
typedef enum
{- BRANCH,
- COLON,
- CONSTANT,
- CREATE,
- DO,
- DOES,
- IF,
- LITERAL,
- LOOP,
- PLOOP,
- PRIMITIVE,
- QDO,
- STRINGLIT,
- USER,
+ BRANCH,
+ COLON,
+ CONSTANT,
+ CREATE,
+ DO,
+ DOES,
+ IF,
+ LITERAL,
+ LOOP,
+ PLOOP,
+ PRIMITIVE,
+ QDO,
+ STRINGLIT,
+ USER,
VARIABLE,
} WORDKIND;
--- a/math64.c
+++ b/math64.c
@@ -5,8 +5,37 @@
** 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.3 2000/06/17 14:43:47 jsadler Exp $
+** $Id: math64.c,v 1.4 2001/04/25 18:59:09 jsadler Exp $
*******************************************************************/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include "ficl.h"
#include "math64.h"
@@ -310,7 +339,7 @@
/**************************************************************************
** Contributed by
-** Michael A. Gauland gaulandm@mdhost.cse.tek.com
+** Michael A. Gauland gaulandm@mdhost.cse.tek.com
**************************************************************************/
#if PORTABLE_LONGMULDIV != 0
/**************************************************************************
@@ -453,7 +482,7 @@
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
+** Michael A. Gauland gaulandm@mdhost.cse.tek.com
**************************************************************************/
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
{@@ -480,7 +509,7 @@
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
+** Michael A. Gauland gaulandm@mdhost.cse.tek.com
**************************************************************************/
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
{--- a/math64.h
+++ b/math64.h
@@ -3,31 +3,36 @@
** 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.3 2000/06/17 14:43:47 jsadler Exp $
+** $Id: math64.h,v 1.4 2001/04/25 18:58:48 jsadler Exp $
*******************************************************************/
/*
-** N O T I C E -- DISCLAIMER OF WARRANTY
+** 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
**
-** Ficl is freeware. Use it in any way that you like, with
-** the understanding that the code is not supported.
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
**
-** Any third party may reproduce, distribute, or modify the ficl
-** software code or any derivative works thereof without any
-** compensation or license, provided that the author information
-** and this disclaimer text are retained in the source code files.
** The ficl software code is provided on an "as is" basis without
** warranty of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular purpose
** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
** 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 (yay!), please
** send me email at the address above.
-**
-** NOTE: this file depends on sysdep.h for the definition
-** of PORTABLE_LONGMULDIV and several abstract types.
-**
*/
#if !defined (__MATH64_H__)
--- a/search.c
+++ b/search.c
@@ -4,8 +4,37 @@
** 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.2 2000/06/17 14:43:57 jsadler Exp $
+** $Id: search.c,v 1.3 2001/04/25 18:59:22 jsadler Exp $
*******************************************************************/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <string.h>
#include "ficl.h"
@@ -185,7 +214,7 @@
/**************************************************************************
- w o r d l i s t
+ 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
@@ -199,7 +228,7 @@
** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
** : wordlist 1 ficl-wordlist ;
**************************************************************************/
-static void wordlist(FICL_VM *pVM)
+static void ficlWordlist(FICL_VM *pVM)
{FICL_DICT *dp = ficlGetDict();
FICL_HASH *pHash;
@@ -209,15 +238,7 @@
vmCheckStack(pVM, 1, 1);
#endif
nBuckets = stackPopUNS(pVM->pStack);
-
- dictAlign(dp);
- pHash = (FICL_HASH *)dp->here;
- dictAllot(dp, sizeof (FICL_HASH)
- + (nBuckets-1) * sizeof (FICL_WORD *));
-
- pHash->size = nBuckets;
- hashReset(pHash);
-
+ pHash = dictCreateWordlist(dp, nBuckets);
stackPushPtr(pVM->pStack, pHash);
return;
}
@@ -273,15 +294,15 @@
static void widGetName(FICL_VM *pVM)
{FICL_HASH *pHash = vmPop(pVM).p;
- char *cp = pHash->name;
- int len = 0;
-
- if (cp)
- len = strlen(cp);
+ char *cp = pHash->name;
+ int len = 0;
+
+ if (cp)
+ len = strlen(cp);
- vmPush(pVM, LVALUEtoCELL(cp));
- vmPush(pVM, LVALUEtoCELL(len));
- return;
+ vmPush(pVM, LVALUEtoCELL(cp));
+ vmPush(pVM, LVALUEtoCELL(len));
+ return;
}
/**************************************************************************
@@ -291,10 +312,10 @@
**************************************************************************/
static void widSetName(FICL_VM *pVM)
{- char *cp = (char *)vmPop(pVM).p;
- FICL_HASH *pHash = vmPop(pVM).p;
- pHash->name = cp;
- return;
+ char *cp = (char *)vmPop(pVM).p;
+ FICL_HASH *pHash = vmPop(pVM).p;
+ pHash->name = cp;
+ return;
}
@@ -324,8 +345,9 @@
** Builds the primitive wordset and the environment-query namespace.
**************************************************************************/
-void ficlCompileSearch(FICL_DICT *dp)
+void ficlCompileSearch(FICL_SYSTEM *pSys)
{+ FICL_DICT *dp = pSys->dp;
assert (dp);
/*
@@ -345,9 +367,8 @@
dictAppendWord(dp, "set-current",
setCurrent, FW_DEFAULT);
dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
- dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT);
- dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT);
- dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT);
+ dictAppendWord(dp, "ficl-wordlist",
+ ficlWordlist, FW_DEFAULT);
/*
** Set SEARCH environment query values
@@ -356,6 +377,8 @@
ficlSetEnv("search-order-ext", FICL_TRUE); ficlSetEnv("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;
--- a/softwords/classes.fr
+++ b/softwords/classes.fr
@@ -1,3 +1,4 @@
+\ #if (FICL_WANT_OOP)
\ ** ficl/softwords/classes.fr
\ ** F I C L 2 . 0 C L A S S E S
\ john sadler 1 sep 98
@@ -103,7 +104,7 @@
;
\ index the pointer in place
- : index-ptr { index 2this -- }+ : index-ptr { index 2:this -- }this --> get-ptr ( addr )
this --> @size index * + ( addr' )
this --> set-ptr
@@ -168,3 +169,4 @@
previous definitions
+\ #endif
--- a/softwords/ficlclass.fr
+++ b/softwords/ficlclass.fr
@@ -1,3 +1,4 @@
+\ #if (FICL_WANT_OOP)
\ ** ficl/softwords/ficlclass.fr
\ Classes to model ficl data structures in objects
\ This is a demo!
@@ -52,7 +53,7 @@
: pop 2drop previous ;
: set-current drop set-current ;
: get-name drop wid-get-name ;
- : words { 2this -- }+ : words { 2:this -- }this my=[ .size get ] 0 do
i this my=[ .hash index ] ( 2list-head )
begin
@@ -80,4 +81,4 @@
--> .sp --> .addr --> prev --> get ;
end-class
-
+#endif
--- a/softwords/forml.fr
+++ b/softwords/forml.fr
@@ -19,7 +19,7 @@
--> .length --> get
;
- : set-name { c-addr u 2this -- }+ : set-name { c-addr u 2:this -- }u this --> .length --> set
c-addr this --> .name u move
;
@@ -47,13 +47,13 @@
object subclass c-led
c-byte obj: .state
- : on { led# 2this -- }+ : on { led# 2:this -- }this --> .state --> get
1 led# lshift or dup !oreg
this --> .state --> set
;
- : off { led# 2this -- }+ : off { led# 2:this -- }this --> .state --> get
1 led# lshift invert and dup !oreg
this --> .state --> set
@@ -64,7 +64,7 @@
object subclass c-switch
- : ?on { bit# 2this -- flag }+ : ?on { bit# 2:this -- flag }1 bit# lshift
;
--- a/softwords/jhlocal.fr
+++ b/softwords/jhlocal.fr
@@ -24,15 +24,20 @@
: ?| ( c-addr u -- c-addr u flag )
2dup s" |" compare 0= ;
-\ examine name - if it's a 2local (starts with '2'),
-\ nibble the first char (the '2') off the name and push true.
+\ 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 c@ [char] 2 =
+ over dup c@ [char] 2 =
+ swap 1+ c@ [char] : = and
if
- 1- swap char+ swap \ dcs/jws: nibble the '2'
+ 2 - swap char+ char+ swap \ dcs/jws: nibble the '2:'
true
- else false endif ;
+ else
+ false
+ endif
+;
: ?delim ( c-addr u -- state | c-addr u 0 )
?| if 2drop 1 exit endif
--- a/softwords/oo.fr
+++ b/softwords/oo.fr
@@ -1,3 +1,4 @@
+\ #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
@@ -63,7 +64,7 @@
postpone sliteral
; compile-only
-: lookup-method { class 2name -- class xt }+: lookup-method { class 2:name -- class xt }name class cell+ @ ( c-addr u wid )
search-wordlist ( 0 | xt 1 | xt -1 )
0= if
@@ -356,7 +357,7 @@
;
\ Create an anonymous initialized instance from the dictionary
-: allot { 2this -- 2instance }+: allot { 2:this -- 2:instance }here ( instance-address )
this my=> get-size allot
this drop 2dup --> init
@@ -363,7 +364,7 @@
;
\ Create an anonymous array of initialized instances from the dictionary
-: allot-array { nobj 2this -- 2instance }+: allot-array { nobj 2:this -- 2:instance }here ( instance-address )
this my=> get-size nobj * allot
this drop 2dup ( 2instance 2instance )
@@ -389,7 +390,7 @@
\ ( and whatever else goes in c-akbar )
\ end-class ( done with c-akbar )
\
-: resume-class { 2this -- old-wid addr[size] size }+: 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
@@ -577,3 +578,4 @@
only definitions
+\ #endif
\ No newline at end of file
--- a/softwords/softcore.bat
+++ b/softwords/softcore.bat
@@ -1,1 +1,1 @@
-\perl\bin\perl.exe softcore.pl softcore.fr jhlocal.fr marker.fr ifbrack.fr oo.fr classes.fr string.fr >..\softcore.c
+perl softcore.pl softcore.fr jhlocal.fr marker.fr prefix.fr ifbrack.fr oo.fr classes.fr string.fr >..\softcore.c
--- a/softwords/softcore.pl
+++ b/softwords/softcore.pl
@@ -13,15 +13,47 @@
** 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
*/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include "ficl.h"
static char softWords[] =
+#if FICL_WANT_SOFTWORDS
EOF
;
@@ -83,12 +115,16 @@
}
print <<EOF
+#endif /* WANT_SOFTWORDS */
"quit ";
-void ficlCompileSoftCore(FICL_VM *pVM)
+void ficlCompileSoftCore(FICL_SYSTEM *pSys)
{+ FICL_VM *pVM = pSys->vmList;
int ret = sizeof (softWords);
+ assert(pVM);
+
ret = ficlExec(pVM, softWords);
if (ret == VM_ERREXIT)
assert(FALSE);
--- a/softwords/string.fr
+++ b/softwords/string.fr
@@ -1,3 +1,4 @@
+\ #if (FICL_WANT_OOP)
\ ** ficl/softwords/string.fr
\ A useful dynamic string class
\ John Sadler 14 Sep 1998
@@ -20,28 +21,28 @@
c-ptr obj: .buf
32 constant min-buf
- : get-count ( 2this -- count ) my=[ .count get ] ;
- : set-count ( count 2this -- ) my=[ .count set ] ;
+ : get-count ( 2:this -- count ) my=[ .count get ] ;
+ : set-count ( count 2:this -- ) my=[ .count set ] ;
- : ?empty ( 2this -- flag ) --> get-count 0= ;
+ : ?empty ( 2:this -- flag ) --> get-count 0= ;
- : get-buflen ( 2this -- len ) my=[ .buflen get ] ;
- : set-buflen ( len 2this -- ) my=[ .buflen set ] ;
+ : get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
+ : set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
- : get-buf ( 2this -- ptr ) my=[ .buf get-ptr ] ;
- : set-buf { ptr len 2this -- } + : 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 ( 2this -- )
+ : 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 { 2this -- }+ : free-buf { 2:this -- }this my=> get-buf
?dup if
free
@@ -51,7 +52,7 @@
;
\ guarantee buffer is large enough to hold size chars
- : size-buf { size 2this -- }+ : size-buf { size 2:this -- }size 0< abort" need positive size for size-buf"
size 0= if
this --> free-buf exit
@@ -77,19 +78,19 @@
endif
;
- : set { c-addr u 2this -- }+ : set { c-addr u 2:this -- }u this --> size-buf
u this --> set-count
c-addr this --> get-buf u move
;
- : get { 2this -- c-addr u }+ : get { 2:this -- c-addr u }this --> get-buf
this --> get-count
;
\ append string to existing one
- : cat { c-addr u 2this -- }+ : 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
@@ -96,7 +97,7 @@
r> this --> set-count
;
- : type { 2this -- }+ : type { 2:this -- }this --> ?empty if ." (empty) " exit endif
this --> .buf --> get-ptr
this --> .count --> get
@@ -103,7 +104,7 @@
type
;
- : compare ( 2string 2this -- n )
+ : compare ( 2string 2:this -- n )
--> get
2swap
--> get
@@ -110,12 +111,12 @@
2swap compare
;
- : hashcode ( 2this -- hashcode )
+ : hashcode ( 2:this -- hashcode )
--> get hash
;
\ destructor method (overrides object --> free)
- : free ( 2this -- ) 2dup --> free-buf object => free ;
+ : free ( 2:this -- ) 2dup --> free-buf object => free ;
end-class
@@ -122,21 +123,21 @@
c-string subclass c-hashstring
c-2byte obj: .hashcode
- : set-hashcode { 2this -- }+ : set-hashcode { 2:this -- }this --> super --> hashcode
this --> .hashcode --> set
;
- : get-hashcode ( 2this -- hashcode )
+ : get-hashcode ( 2:this -- hashcode )
--> .hashcode --> get
;
- : set ( c-addr u 2this -- )
+ : set ( c-addr u 2:this -- )
2swap 2over --> super --> set
--> set-hashcode
;
- : cat ( c-addr u 2this -- )
+ : cat ( c-addr u 2:this -- )
2swap 2over --> super --> cat
--> set-hashcode
;
@@ -144,3 +145,4 @@
end-class
previous definitions
+\ #endif
--- a/stack.c
+++ b/stack.c
@@ -3,8 +3,37 @@
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 16 Oct 1997
-** $Id: stack.c,v 1.3 2000/06/17 14:43:48 jsadler Exp $
+** $Id: stack.c,v 1.4 2001/04/25 18:59:09 jsadler Exp $
*******************************************************************/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include "ficl.h"
@@ -48,6 +77,24 @@
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
**
@@ -206,6 +253,12 @@
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
@@ -231,6 +284,13 @@
{*pStack->sp++ = LVALUEtoCELL(i);
}
+
+#if (FICL_WANT_FLOAT)
+void stackPushFloat(FICL_STACK *pStack, float f)
+{+ *pStack->sp++ = LVALUEtoCELL(f);
+}
+#endif
/*******************************************************************
s t a c k R e s e t
--- a/sysdep.c
+++ b/sysdep.c
@@ -6,8 +6,37 @@
** Implementations of FICL external interface functions...
**
** (simple) port to Linux, Skip Carter 26 March 1998
-** $Id: sysdep.c,v 1.4 2000/06/17 14:43:49 jsadler Exp $
+** $Id: sysdep.c,v 1.5 2001/04/25 18:59:12 jsadler Exp $
*******************************************************************/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <stdio.h>
@@ -15,9 +44,91 @@
#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 ***********************
*/
-#if defined (_M_IX86)
+#elif defined (_M_IX86)
#if PORTABLE_LONGMULDIV == 0
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
@@ -102,8 +213,8 @@
#if FICL_MULTITHREAD
int ficlLockDictionary(short fLock)
{- IGNORE(fLock);
- return 0;
+ IGNORE(fLock);
+ return 0;
}
#endif /* FICL_MULTITHREAD */
@@ -166,12 +277,12 @@
void *ficlRealloc(void *p, size_t size)
{- void *pv = malloc(size);
+ void *pv = malloc(size);
if (p)
- {- memcpy(pv, p, size)
+ {+ memcpy(pv, p, size)
free(p);
- }
+ }
return pv;
}
@@ -193,8 +304,8 @@
#if FICL_MULTITHREAD
int ficlLockDictionary(short fLock)
{- IGNORE(fLock);
- return 0;
+ IGNORE(fLock);
+ return 0;
}
#endif /* FICL_MULTITHREAD */
@@ -204,9 +315,15 @@
******************* Linux P O R T B E G I N S H E R E ******************** Skip Carter, March 1998
*/
-#ifdef linux
+#if defined(linux) || defined(riscos)
#if PORTABLE_LONGMULDIV == 0
+
+#ifdef riscos
+typedef unsigned long long __u64;
+typedef unsigned long __u32;
+#endif
+
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
{DPUNS q;
@@ -279,8 +396,8 @@
#if FICL_MULTITHREAD
int ficlLockDictionary(short fLock)
{- IGNORE(fLock);
- return 0;
+ IGNORE(fLock);
+ return 0;
}
#endif /* FICL_MULTITHREAD */
--- a/sysdep.h
+++ b/sysdep.h
@@ -9,23 +9,32 @@
** FICL_ROBUST is enabled. This may require some consideration
** in firmware systems since assert often
** assumes stderr/stdout.
-** $Id: sysdep.h,v 1.4 2000/06/17 14:43:49 jsadler Exp $
+** $Id: sysdep.h,v 1.5 2001/04/25 19:00:10 jsadler Exp $
*******************************************************************/
/*
-** N O T I C E -- DISCLAIMER OF WARRANTY
+** 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
**
-** Ficl is freeware. Use it in any way that you like, with
-** the understanding that the code is not supported.
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
**
-** Any third party may reproduce, distribute, or modify the ficl
-** software code or any derivative works thereof without any
-** compensation or license, provided that the author information
-** and this disclaimer text are retained in the source code files.
** The ficl software code is provided on an "as is" basis without
** warranty of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular purpose
** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
** 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 (yay!), please
@@ -39,6 +48,14 @@
#include <setjmp.h>
#include <assert.h>
+#if defined(_WIN32)
+ #define alloca(x) _alloca(x)
+ #define stat _stat
+ #define getcwd _getcwd
+ #define chdir _chdir
+#elif defined(linux)
+#endif /* platform */
+
#if !defined IGNORE /* Macro to silence unused param warnings */
#define IGNORE(x) &x
#endif
@@ -55,7 +72,20 @@
#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...
*/
@@ -83,6 +113,7 @@
** 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
@@ -92,6 +123,10 @@
#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
*/
@@ -129,23 +164,120 @@
/*
-** Build controls
-** FICL_MULTITHREAD enables dictionary mutual exclusion
-** wia the ficlLockDictionary system dependent function.
+** B U I L D C O N T R O L S
*/
-#if !defined FICL_MULTITHREAD
-#define FICL_MULTITHREAD 0
+
+#if !defined (FICL_MINIMAL)
+#define FICL_MINIMAL 0
#endif
+#if (FICL_MINIMAL)
+#define FICL_WANT_SOFTWORDS 0
+#define FICL_WANT_FLOAT 0
+#define FICL_WANT_USER 0
+#define FICL_WANT_LOCALS 0
+#define FICL_WANT_DEBUGGER 0
+#define FICL_WANT_OOP 0
+#define FICL_PLATFORM_EXTEND 0
+#define FICL_MULTITHREAD 0
+#define FICL_ROBUST 0
+#define FICL_EXTENDED_PREFIX 0
+#endif
/*
+** FICL_PLATFORM_EXTEND
+** Includes words defined in ficlCompilePlatform (see win32.c for example)
+*/
+#ifdef _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_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
-** Includes ficl code necesary to single step the VM. Turned on in ficlWin.
+** Inludes a simple source level debugger
*/
#if !defined (FICL_WANT_DEBUGGER)
-#define FICL_WANT_DEBUGGER 0
+#define FICL_WANT_DEBUGGER 1
#endif
/*
+** User variables: per-instance variables bound to the VM.
+** Kinda like thread-local storage. Could be implemented in a
+** VM private dictionary, but I've chosen the lower overhead
+** approach of an array of CELLs instead.
+*/
+#if !defined FICL_WANT_USER
+#define FICL_WANT_USER 1
+#endif
+
+#if !defined FICL_USER_CELLS
+#define FICL_USER_CELLS 16
+#endif
+
+/*
+** FICL_WANT_LOCALS controls the creation of the LOCALS wordset and
+** a private dictionary for local variable compilation.
+*/
+#if !defined FICL_WANT_LOCALS
+#define FICL_WANT_LOCALS 1
+#endif
+
+/* Max number of local variables per definition */
+#if !defined FICL_MAX_LOCALS
+#define FICL_MAX_LOCALS 16
+#endif
+
+/*
+** FICL_WANT_OOP
+** Inludes object oriented programming support (in softwords)
+** OOP support requires locals and user variables!
+*/
+#if !(FICL_WANT_LOCALS) || !(FICL_WANT_USER)
+#if !defined (FICL_WANT_OOP)
+#define FICL_WANT_OOP 0
+#endif
+#endif
+
+#if !defined (FICL_WANT_OOP)
+#define FICL_WANT_OOP 1
+#endif
+
+/*
+** FICL_WANT_SOFTWORDS
+** Controls inclusion of all softwords in softcore.c
+*/
+#if !defined (FICL_WANT_SOFTWORDS)
+#define FICL_WANT_SOFTWORDS 1
+#endif
+
+/*
+** FICL_MULTITHREAD enables dictionary mutual exclusion
+** wia the ficlLockDictionary system dependent function.
+** Note: this implementation is experimental and poorly
+** tested. Further, it's unnecessary unless you really
+** intend to have multiple SESSIONS (poor choice of name
+** on my part) - that is, threads that modify the dictionary
+** at the same time.
+*/
+#if !defined FICL_MULTITHREAD
+#define FICL_MULTITHREAD 0
+#endif
+
+/*
** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
** defined in C in sysdep.c. Use this if you cannot easily
** generate an inline asm definition
@@ -154,7 +286,6 @@
#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
@@ -216,30 +347,21 @@
#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.
+** 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_WANT_USER
-#define FICL_WANT_USER 1
+#if !defined FICL_MAX_PARSE_STEPS
+#define FICL_MAX_PARSE_STEPS 8
#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.
+/*
+** 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_LOCALS
-#define FICL_WANT_LOCALS 1
-#endif
-
-/* Max number of local variables per definition */
-#if !defined FICL_MAX_LOCALS
-#define FICL_MAX_LOCALS 16
+#if !defined FICL_EXTENDED_PREFIX
+#define FICL_EXTENDED_PREFIX 0
#endif
/*
--- a/test/ficltest.fr
+++ b/test/ficltest.fr
@@ -69,3 +69,17 @@
{ exctest1 -> 1 } { exctest2 -> 2 } { exctest? abort -> -1 }+
+testing refill
+0 [if]
+.( Error )
+[else]
+1 [if]
+[else]
+.( Error )
+[then]
+[then]
+
+testing prefixes
+{ 0x10 -> decimal 16 }+{ hex 0d10 -> decimal 10 }--- a/testmain.c
+++ b/testmain.c
@@ -1,6 +1,6 @@
/*
** stub main for testing FICL under Win32
-** $Id: testmain.c,v 1.6 2000/06/17 14:43:50 jsadler Exp $
+** $Id: testmain.c,v 1.7 2001/04/25 18:59:53 jsadler Exp $
*/
#include <stdlib.h>
@@ -7,7 +7,7 @@
#include <stdio.h>
#include <string.h>
#include <time.h>
-#ifdef WIN32
+#if defined (_WIN32)
#include <direct.h>
#endif
#include <sys/types.h>
@@ -27,7 +27,7 @@
{char *cp;
-#ifdef WIN32
+#if defined (_WIN32)
cp = _getcwd(NULL, 80);
#else
cp = getcwd(NULL, 80);
@@ -50,11 +50,7 @@
vmGetString(pVM, pFS, '\n');
if (pFS->count > 0)
{-#ifdef WIN32
- int err = _chdir(pFS->text);
-#else
int err = chdir(pFS->text);
-#endif
if (err)
{vmTextOut(pVM, "Error: path not found", 1);
@@ -115,11 +111,7 @@
FILE *fp;
int result;
CELL id;
-#ifdef WIN32
- struct _stat buf;
-#else
struct stat buf;
-#endif
vmGetString(pVM, pFilename, '\n');
@@ -133,11 +125,7 @@
/*
** get the file's size and make sure it exists
*/
-#ifdef WIN32
- result = _stat( pFilename->text, &buf );
-#else
result = stat( pFilename->text, &buf );
-#endif
if (result != 0)
{@@ -170,12 +158,18 @@
cp[len] = '\0';
result = ficlExec(pVM, cp);
- if (result != VM_OUTOFTEXT)
+ /* handle "bye" in loaded files. --lch */
+ switch (result)
{- pVM->sourceID = id;
- fclose(fp);
- vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
- break;
+ 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;
}
}
/*
@@ -188,6 +182,9 @@
pVM->sourceID = id;
fclose(fp);
+ /* handle "bye" in loaded files. --lch */
+ if (result == VM_USEREXIT)
+ vmThrow(pVM, VM_USEREXIT);
return;
}
@@ -260,32 +257,17 @@
}
-static void execxt(FICL_VM *pVM)
+void buildTestInterface()
{- FICL_WORD *pFW;
-#if FICL_ROBUST > 1
- vmCheckStack(pVM, 1, 0);
-#endif
-
- pFW = stackPopPtr(pVM->pStack);
- ficlExecXT(pVM, pFW);
-
- return;
-}
-
-
-void buildTestInterface(void)
-{ ficlBuild("break", ficlBreak, FW_DEFAULT); ficlBuild("clock", ficlClock, FW_DEFAULT); ficlBuild("cd", ficlChDir, FW_DEFAULT);- ficlBuild("execxt", execxt, FW_DEFAULT); ficlBuild("load", ficlLoad, FW_DEFAULT); ficlBuild("pwd", ficlGetCWD, FW_DEFAULT); ficlBuild("system", ficlSystem, FW_DEFAULT); ficlBuild("spewhash", spewHash, FW_DEFAULT); ficlBuild("clocks/sec", - clocksPerSec, FW_DEFAULT);
+ clocksPerSec, FW_DEFAULT);
return;
}
@@ -295,14 +277,14 @@
#define nINBUF 256
int main(int argc, char **argv)
{+ int ret = 0;
char in[nINBUF];
FICL_VM *pVM;
-
ficlInitSystem(10000);
buildTestInterface();
pVM = ficlNewVM();
- ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
+ ret = ficlExec(pVM, ".ver .( " __DATE__ " ) cr quit");
/*
** load file from cmd line...
@@ -310,21 +292,16 @@
if (argc > 1)
{sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
- ficlExec(pVM, in);
+ ret = ficlExec(pVM, in);
}
- for (;;)
+ while (ret != VM_USEREXIT)
{- int ret;
fgets(in, nINBUF, stdin);
ret = ficlExec(pVM, in);
- if (ret == VM_USEREXIT)
- {- ficlTermSystem();
- break;
- }
}
+ ficlTermSystem();
return 0;
}
--- a/tools.c
+++ b/tools.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - programming tools
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 20 June 2000
-** $Id: tools.c,v 1.2 2000/10/01 23:50:41 jsadler Exp $
+** $Id: tools.c,v 1.3 2001/04/25 19:00:33 jsadler Exp $
*******************************************************************/
/*
** NOTES:
@@ -14,13 +14,39 @@
** colonParen doDoes createParen variableParen userParen constantParen
**
** Step and break debugger for Ficl
-** The debugger requies real implementations of KEY and ACCEPT
-** because it bypasses the normal VM return mechanism for getting
-** text??
** debug ( xt -- ) Start debugging an xt
** Set a breakpoint
** Specify breakpoint default action
*/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <stdio.h> /* sprintf */
@@ -49,37 +75,19 @@
*/
typedef struct breakpoint
{- void *address;
+ void *address;
FICL_WORD *origXT;
} BREAKPOINT;
static BREAKPOINT bpStep = {NULL, NULL};-static FICL_WORD *pStep = NULL;
-static FICL_WORD *pOnStep = NULL;
-#if 0
-/**************************************************************************
- i n i t T o o l s
-** Initializes static variables of this file, including:
-** 1. The lookup table of control structure XTs used by isDebuggable and
-** see
-** 2. The breakpoint table
-** This routine MUST execute AFTER the core dictionary is successfully
-** built, and AFTER debug words are inserted into the dictionary, but
-** BEFORE any use of the debugger.
-**************************************************************************/
-static void initTools(FICL_VM *pVM)
-{- FICL_DICT *dp = ficlGetDict();
- &pVM;
-
- return;
-}
-#endif
-
-
+/*
+** vmSetBreak - set a breakpoint at the current value of IP by
+** storing that address in a BREAKPOINT record
+*/
static void vmSetBreak(FICL_VM *pVM, BREAKPOINT *pBP)
{+ FICL_WORD *pStep = ficlLookup("step-break");assert(pStep);
pBP->address = pVM->ip;
pBP->origXT = *pVM->ip;
@@ -95,7 +103,7 @@
** like it's in the dictionary address range.
** NOTE: this excludes :noname words!
*/
-static int isAFiclWord(FICL_WORD *pFW)
+int isAFiclWord(FICL_WORD *pFW)
{FICL_DICT *pd = ficlGetDict();
@@ -135,9 +143,9 @@
{static FICL_WORD *pSemiParen = NULL;
- if (!pSemiParen)
- pSemiParen = ficlLookup("(;)");- assert(pSemiParen);
+ if (!pSemiParen)
+ pSemiParen = ficlLookup("(;)");+ assert(pSemiParen);
for (; pc->p != pSemiParen; pc++)
{@@ -145,63 +153,63 @@
if (isAFiclWord(pFW))
{- WORDKIND kind = ficlWordClassify(pFW);
- CELL c;
+ WORDKIND kind = ficlWordClassify(pFW);
+ CELL c;
- switch (kind)
- {- case LITERAL:
- c = *++pc;
- if (isAFiclWord(c.p))
- {- FICL_WORD *pLit = (FICL_WORD *)c.p;
- sprintf(pVM->pad, " literal %.*s (%#lx)",
- pLit->nName, pLit->name, c.u);
- }
- else
- sprintf(pVM->pad, " literal %ld (%#lx)", c.i, c.u);
- break;
+ switch (kind)
+ {+ case LITERAL:
+ c = *++pc;
+ if (isAFiclWord(c.p))
+ {+ FICL_WORD *pLit = (FICL_WORD *)c.p;
+ sprintf(pVM->pad, " literal %.*s (%#lx)",
+ pLit->nName, pLit->name, c.u);
+ }
+ else
+ sprintf(pVM->pad, " 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(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
- }
- break;
- case IF:
- c = *++pc;
- if (c.i > 0)
- sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
- else
- sprintf(pVM->pad, " until (branch rel %ld)", c.i);
- break;
- case BRANCH:
- c = *++pc;
- if (c.i > 0)
- sprintf(pVM->pad, " else (branch rel %ld)", c.i);
- else
- sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
- break;
+ {+ FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
+ pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
+ sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text);
+ }
+ break;
+ case IF:
+ c = *++pc;
+ if (c.i > 0)
+ sprintf(pVM->pad, " if / while (branch rel %ld)", c.i);
+ else
+ sprintf(pVM->pad, " until (branch rel %ld)", c.i);
+ break;
+ case BRANCH:
+ c = *++pc;
+ if (c.i > 0)
+ sprintf(pVM->pad, " else (branch rel %ld)", c.i);
+ else
+ sprintf(pVM->pad, " repeat (branch rel %ld)", c.i);
+ break;
- case QDO:
- c = *++pc;
- sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
- break;
- case DO:
- c = *++pc;
- sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
- break;
+ case QDO:
+ c = *++pc;
+ sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u);
+ break;
+ case DO:
+ c = *++pc;
+ sprintf(pVM->pad, " do (leave abs %#lx)", c.u);
+ break;
case LOOP:
- c = *++pc;
- sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
- break;
- case PLOOP:
- c = *++pc;
- sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
- break;
- default:
+ c = *++pc;
+ sprintf(pVM->pad, " loop (branch rel %#ld)", c.i);
+ break;
+ case PLOOP:
+ c = *++pc;
+ sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i);
+ break;
+ default:
sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name);
- break;
+ break;
}
vmTextOut(pVM, pVM->pad, 1);
@@ -227,45 +235,45 @@
static void seeXT(FICL_VM *pVM)
{FICL_WORD *pFW;
- WORDKIND kind;
+ WORDKIND kind;
pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
- kind = ficlWordClassify(pFW);
+ kind = ficlWordClassify(pFW);
- switch (kind)
- {- case COLON:
+ switch (kind)
+ {+ case COLON:
sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
vmTextOut(pVM, pVM->pad, 1);
seeColon(pVM, pFW->param);
- break;
+ break;
- case DOES:
+ case DOES:
vmTextOut(pVM, "does>", 1);
seeColon(pVM, (CELL *)pFW->param->p);
- break;
+ break;
- case CREATE:
+ case CREATE:
vmTextOut(pVM, "create", 1);
- break;
+ break;
case VARIABLE:
sprintf(pVM->pad, "variable = %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
- break;
+ break;
- case USER:
+ case USER:
sprintf(pVM->pad, "user variable %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
- break;
+ break;
- case CONSTANT:
+ case CONSTANT:
sprintf(pVM->pad, "constant = %ld (%#lx)", pFW->param->i, pFW->param->u);
vmTextOut(pVM, pVM->pad, 1);
- default:
+ default:
vmTextOut(pVM, "primitive", 1);
- break;
+ break;
}
if (pFW->flags & FW_IMMEDIATE)
@@ -284,9 +292,9 @@
static void see(FICL_VM *pVM)
{- ficlTick(pVM);
- seeXT(pVM);
- return;
+ ficlTick(pVM);
+ seeXT(pVM);
+ return;
}
@@ -300,23 +308,22 @@
**************************************************************************/
void ficlDebugXT(FICL_VM *pVM)
{- FICL_WORD *xt = stackPopPtr(pVM->pStack);
- WORDKIND wk = ficlWordClassify(xt);
+ FICL_WORD *xt = stackPopPtr(pVM->pStack);
+ WORDKIND wk = ficlWordClassify(xt);
+ FICL_WORD *pStep = ficlLookup("step-break");assert(pStep);
- pOnStep = ficlLookup("on-step");-
stackPushPtr(pVM->pStack, xt);
seeXT(pVM);
- switch (wk)
- {- case COLON:
+ switch (wk)
+ {+ case COLON:
case DOES:
- /*
- ** Run the colon code and set a breakpoint at the next instruction
- */
+ /*
+ ** Run the colon code and set a breakpoint at the next instruction
+ */
vmExecute(pVM, xt);
bpStep.address = pVM->ip;
bpStep.origXT = *pVM->ip;
@@ -325,7 +332,7 @@
default:
break;
- }
+ }
return;
}
@@ -339,7 +346,6 @@
**************************************************************************/
void stepIn(FICL_VM *pVM)
{- assert(pStep);
/*
** Do one step of the inner loop
*/
@@ -366,16 +372,17 @@
void stepOver(FICL_VM *pVM)
{FICL_WORD *pFW;
- WORDKIND kind;
+ WORDKIND kind;
+ FICL_WORD *pStep = ficlLookup("step-break");assert(pStep);
pFW = *pVM->ip;
- kind = ficlWordClassify(pFW);
+ kind = ficlWordClassify(pFW);
- switch (kind)
- {- case COLON:
- case DOES:
+ switch (kind)
+ {+ case COLON:
+ case DOES:
/*
** assume that the next cell holds an instruction
** set a breakpoint there and return to the inner interp
@@ -383,9 +390,9 @@
bpStep.address = pVM->ip + 1;
bpStep.origXT = pVM->ip[1];
pVM->ip[1] = pStep;
- break;
+ break;
- default:
+ default:
stepIn(pVM);
break;
}
@@ -414,6 +421,7 @@
{STRINGINFO si;
FICL_WORD *pFW;
+ FICL_WORD *pOnStep = ficlLookup("on-step");if (!pVM->fRestart)
{@@ -455,23 +463,23 @@
si = vmGetWord(pVM);
- if (!strincmp(si.cp, "i", (unsigned char)si.count))
+ if (!strincmp(si.cp, "i", si.count))
{stepIn(pVM);
}
- else if (!strincmp(si.cp, "g", (unsigned char)si.count))
+ else if (!strincmp(si.cp, "g", si.count))
{return;
}
- else if (!strincmp(si.cp, "o", (unsigned char)si.count))
+ else if (!strincmp(si.cp, "o", si.count))
{stepOver(pVM);
}
- else if (!strincmp(si.cp, "q", (unsigned char)si.count))
+ else if (!strincmp(si.cp, "q", si.count))
{vmThrow(pVM, VM_ABORT);
}
- else if (!strincmp(si.cp, "?", (unsigned char)si.count))
+ else if (!strincmp(si.cp, "?", si.count))
{vmTextOut(pVM, "i -- step In", 1);
vmTextOut(pVM, "o -- step Over", 1);
@@ -484,7 +492,7 @@
vmThrow(pVM, VM_ABORT);
}
- return;
+ return;
}
@@ -657,7 +665,7 @@
/**************************************************************************
l i s t E n v
-**
+** Print symbols defined in the environment
**************************************************************************/
static void listEnv(FICL_VM *pVM)
{@@ -683,17 +691,54 @@
/**************************************************************************
+ 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->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->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_DICT *dp)
+void ficlCompileTools(FICL_SYSTEM *pSys)
{+ FICL_DICT *dp = pSys->dp;
assert (dp);
/*
** TOOLS and TOOLS EXT
*/
+ dictAppendWord(dp, ".r", displayRStack, FW_DEFAULT); /* guy carver */
dictAppendWord(dp, ".s", displayStack, FW_DEFAULT);
dictAppendWord(dp, "bye", bye, FW_DEFAULT);
dictAppendWord(dp, "forget", forget, FW_DEFAULT);
@@ -710,8 +755,14 @@
** Ficl extras
*/
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);
- pStep =
+ 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);
--- a/vm.c
+++ b/vm.c
@@ -3,7 +3,7 @@
** Forth Inspired Command Language - virtual machine methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
-** $Id: vm.c,v 1.6 2000/06/17 14:43:50 jsadler Exp $
+** $Id: vm.c,v 1.7 2001/04/25 19:00:17 jsadler Exp $
*******************************************************************/
/*
** This file implements the virtual machine of FICL. Each virtual
@@ -12,6 +12,35 @@
** well as a pile of state variables and the two dedicated registers
** of the interp.
*/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <stdio.h>
@@ -36,7 +65,9 @@
/**************************************************************************
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)
{@@ -55,6 +86,12 @@
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);
@@ -64,7 +101,8 @@
/**************************************************************************
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)
{@@ -72,6 +110,9 @@
{ficlFree(pVM->pStack);
ficlFree(pVM->rStack);
+#if FICL_WANT_FLOAT
+ ficlFree(pVM->fStack);
+#endif
ficlFree(pVM);
}
@@ -194,7 +235,7 @@
/**************************************************************************
v m G e t W o r d T o P a d
-** Does vmGetWord0 and copies the result to the pad as a NULL terminated
+** 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.
**************************************************************************/
@@ -202,7 +243,7 @@
{STRINGINFO si;
char *cp = (char *)pVM->pad;
- si = vmGetWord0(pVM);
+ si = vmGetWord(pVM);
if (SI_COUNT(si) > nPAD)
SI_SETLEN(si, nPAD);
@@ -225,7 +266,7 @@
**************************************************************************/
STRINGINFO vmParseString(FICL_VM *pVM, char delim)
{ - return vmParseStringEx(pVM, delim, 1);
+ return vmParseStringEx(pVM, delim, 1);
}
STRINGINFO vmParseStringEx(FICL_VM *pVM, char delim, char fSkipLeading)
@@ -235,11 +276,11 @@
char *pEnd = vmGetInBufEnd(pVM);
char ch;
- if (fSkipLeading)
- { /* skip lead delimiters */- while ((pSrc != pEnd) && (*pSrc == delim))
- pSrc++;
- }
+ if (fSkipLeading)
+ { /* skip lead delimiters */+ while ((pSrc != pEnd) && (*pSrc == delim))
+ pSrc++;
+ }
SI_SETPTR(si, pSrc); /* mark start of text */
@@ -339,15 +380,10 @@
**************************************************************************/
void vmQuit(FICL_VM *pVM)
{- static FICL_WORD *pInterp = NULL;
- if (!pInterp)
- pInterp = ficlLookup("interpret");- assert(pInterp);
-
stackReset(pVM->rStack);
pVM->fRestart = 0;
- pVM->ip = &pInterp;
- pVM->runningWord = pInterp;
+ pVM->ip = NULL;
+ pVM->runningWord = NULL;
pVM->state = INTERPRET;
pVM->tib.cp = NULL;
pVM->tib.end = NULL;
@@ -366,6 +402,9 @@
{vmQuit(pVM);
stackReset(pVM->pStack);
+#if FICL_WANT_FLOAT
+ stackReset(pVM->fStack);
+#endif
pVM->base = 10;
return;
}
@@ -394,7 +433,7 @@
#if FICL_WANT_DEBUGGER
void vmStep(FICL_VM *pVM)
{- M_VM_STEP(pVM);
+ M_VM_STEP(pVM);
}
#endif
@@ -623,24 +662,22 @@
/**************************************************************************
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_COUNT count)
+int strincmp(char *cp1, char *cp2, FICL_UNS count)
{int i = 0;
- char c1, c2;
- for (c1 = *cp1, c2 = *cp2;
- ((i == 0) && count && c1 && c2);
- c1 = *++cp1, c2 = *++cp2, count--)
+ for (; 0 < count; ++cp1, ++cp2, --count)
{- i = tolower(c1) - tolower(c2);
+ i = tolower(*cp1) - tolower(*cp2);
+ if (i != 0)
+ return i;
+ else if (*cp1 == '\0')
+ return 0;
}
-
- return i;
+ return 0;
}
-
-
/**************************************************************************
s k i p S p a c e
--- a/words.c
+++ b/words.c
@@ -4,8 +4,37 @@
** 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.9 2000/10/01 23:50:40 jsadler Exp $
+** $Id: words.c,v 1.10 2001/04/25 19:00:19 jsadler Exp $
*******************************************************************/
+/*
+** 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
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** 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 (yay!), please
+** send me email at the address above.
+*/
#include <stdlib.h>
#include <stdio.h>
@@ -16,7 +45,7 @@
static void colonParen(FICL_VM *pVM);
static void literalIm(FICL_VM *pVM);
-static void interpWord(FICL_VM *pVM, STRINGINFO si);
+static int ficlParseWord(FICL_VM *pVM, STRINGINFO si);
/*
** Control structure building words use these
@@ -48,6 +77,7 @@
static FICL_WORD *pTwoLitParen = NULL;
static FICL_WORD *pLoopParen = NULL;
static FICL_WORD *pPLoopParen = NULL;
+static FICL_WORD *pPlusStore = NULL;
static FICL_WORD *pQDoParen = NULL;
static FICL_WORD *pSemiParen = NULL;
static FICL_WORD *pStore = NULL;
@@ -82,21 +112,28 @@
*/
static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
{- stackPushPtr(pVM->pStack, dp->here);
- stackPushPtr(pVM->pStack, tag);
+ PUSHPTR(dp->here);
+ PUSHPTR(tag);
return;
}
static void markControlTag(FICL_VM *pVM, char *tag)
{- stackPushPtr(pVM->pStack, tag);
+ PUSHPTR(tag);
return;
}
static void matchControlTag(FICL_VM *pVM, char *tag)
{- char *cp = (char *)stackPopPtr(pVM->pStack);
- if ( strcmp(cp, 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);
}
@@ -116,6 +153,9 @@
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));
@@ -136,6 +176,9 @@
matchControlTag(pVM, tag);
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
patchAddr = (CELL *)stackPopPtr(pVM->pStack);
offset = dp->here - patchAddr;
*patchAddr = LVALUEtoCELL(offset);
@@ -153,8 +196,14 @@
CELL *patchAddr;
char *cp;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
cp = stackPopPtr(pVM->pStack);
- if (strcmp(cp, tag))
+ /*
+ ** 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);
@@ -168,15 +217,15 @@
/**************************************************************************
- i s N u m b e r
+ 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.
**************************************************************************/
-static int isNumber(FICL_VM *pVM, STRINGINFO si)
+int ficlParseNumber(FICL_VM *pVM, STRINGINFO si)
{- FICL_INT accum = 0;
+ FICL_INT accum = 0;
char isNeg = FALSE;
unsigned base = pVM->base;
char *cp = SI_PTR(si);
@@ -184,23 +233,29 @@
unsigned ch;
unsigned digit;
- if (*cp == '-')
+ if (count > 1)
{- cp++;
- count--;
- isNeg = TRUE;
+ switch (*cp)
+ {+ case '-':
+ cp++;
+ count--;
+ isNeg = TRUE;
+ break;
+ case '+':
+ cp++;
+ count--;
+ isNeg = FALSE;
+ break;
+ default:
+ break;
+ }
}
- else if ((cp[0] == '0') && (cp[1] == 'x'))
- { /* detect 0xNNNN format for hex numbers */- cp += 2;
- count -= 2;
- base = 16;
- }
if (count == 0)
return FALSE;
- while (count-- && ((ch = *cp++) != '\0'))
+ while ((count--) && ((ch = *cp++) != '\0'))
{if (!isalnum(ch))
return FALSE;
@@ -219,24 +274,14 @@
if (isNeg)
accum = -accum;
- stackPushINT(pVM->pStack, accum);
+ PUSHINT(accum);
+ if (pVM->state == COMPILE)
+ literalIm(pVM);
return TRUE;
}
-static void ficlIsNum(FICL_VM *pVM)
-{- STRINGINFO si;
- FICL_INT ret;
-
- SI_SETLEN(si, stackPopINT(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- ret = isNumber(pVM, si) ? FICL_TRUE : FICL_FALSE;
- stackPushINT(pVM->pStack, ret);
- return;
-}
-
/**************************************************************************
a d d & f r i e n d s
**
@@ -285,7 +330,7 @@
vmCheckStack(pVM, 1, 1);
#endif
i = -stackPopINT(pVM->pStack);
- stackPushINT(pVM->pStack, i);
+ PUSHINT(i);
return;
}
@@ -324,8 +369,8 @@
i64Extend(n1);
qr = m64SymmetricDivI(n1, n2);
- stackPushINT(pVM->pStack, qr.rem);
- stackPushINT(pVM->pStack, qr.quot);
+ PUSHINT(qr.rem);
+ PUSHINT(qr.quot);
return;
}
@@ -391,7 +436,7 @@
prod = m64MulI(x,y);
x = m64SymmetricDivI(prod, z).quot;
- stackPushINT(pVM->pStack, x);
+ PUSHINT(x);
return;
}
@@ -411,8 +456,8 @@
prod = m64MulI(x,y);
qr = m64SymmetricDivI(prod, z);
- stackPushINT(pVM->pStack, qr.rem);
- stackPushINT(pVM->pStack, qr.quot);
+ PUSHINT(qr.rem);
+ PUSHINT(qr.quot);
return;
}
@@ -659,7 +704,7 @@
vmCheckStack(pVM, 0, 1);
#endif
i = stackDepth(pVM->pStack);
- stackPushINT(pVM->pStack, i);
+ PUSHINT(i);
return;
}
@@ -964,7 +1009,7 @@
vmCheckStack(pVM, 1, 1);
#endif
pw = (UNS32 *)stackPopPtr(pVM->pStack);
- stackPushUNS(pVM->pStack, (FICL_UNS)*pw);
+ PUSHUNS((FICL_UNS)*pw);
return;
}
@@ -985,7 +1030,7 @@
vmCheckStack(pVM, 1, 1);
#endif
pw = (UNS16 *)stackPopPtr(pVM->pStack);
- stackPushUNS(pVM->pStack, (FICL_UNS)*pw);
+ PUSHUNS((FICL_UNS)*pw);
return;
}
@@ -1006,7 +1051,7 @@
vmCheckStack(pVM, 1, 1);
#endif
pc = (UNS8 *)stackPopPtr(pVM->pStack);
- stackPushUNS(pVM->pStack, (FICL_UNS)*pc);
+ PUSHUNS((FICL_UNS)*pc);
return;
}
@@ -1064,7 +1109,7 @@
}
else
{ /* take branch (to else/endif/begin) */- vmBranchRelative(pVM, (int)(*pVM->ip));
+ vmBranchRelative(pVM, *(int *)(pVM->ip));
}
return;
@@ -1139,10 +1184,10 @@
static void hash(FICL_VM *pVM)
{- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, stackPopPtr(pVM->pStack));
- stackPushUNS(pVM->pStack, hashHashCode(si));
+ STRINGINFO si;
+ SI_SETLEN(si, stackPopUNS(pVM->pStack));
+ SI_SETPTR(si, stackPopPtr(pVM->pStack));
+ PUSHUNS(hashHashCode(si));
return;
}
@@ -1169,11 +1214,13 @@
static void interpret(FICL_VM *pVM)
{STRINGINFO si;
+ int i;
+ FICL_SYSTEM *pSys;
+
assert(pVM);
- si = vmGetWord0(pVM);
+ pSys = pVM->pSys;
+ si = vmGetWord0(pVM);
- /* vmBranchRelative(pVM, -1); */
-
/*
** Get next word...if out of text, we're done.
*/
@@ -1182,13 +1229,38 @@
vmThrow(pVM, VM_OUTOFTEXT);
}
- interpWord(pVM, si);
+ /*
+ ** 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];
+ FICL_PARSE_STEP pStep;
+
+ if (pFW == NULL)
+ break;
+ pStep = (FICL_PARSE_STEP)(pFW->param->fn);
+ if ((*pStep)(pVM, si))
+ 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:
@@ -1204,8 +1276,10 @@
** 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 void interpWord(FICL_VM *pVM, STRINGINFO si)
+static int ficlParseWord(FICL_VM *pVM, STRINGINFO si)
{FICL_DICT *dp = ficlGetDict();
FICL_WORD *tempFW;
@@ -1234,13 +1308,8 @@
}
vmExecute(pVM, tempFW);
+ return FICL_TRUE;
}
-
- else if (!isNumber(pVM, si))
- {- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
}
else /* (pVM->state == COMPILE) */
@@ -1255,22 +1324,50 @@
{dictAppendCell(dp, LVALUEtoCELL(tempFW));
}
+ return FICL_TRUE;
}
- else if (isNumber(pVM, si))
- {- literalIm(pVM);
- }
- else
- {- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
}
+ return FICL_FALSE;
+}
+
+
+/**************************************************************************
+ 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;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+ pStep = (FICL_WORD *)(stackPop(pVM->pStack).p);
+ if ((pStep != NULL) && isAFiclWord(pStep))
+ ficlAddParseStep(pVM->pSys, pStep);
+ return;
+}
+
+
/**************************************************************************
l i t e r a l P a r e n
**
@@ -1285,7 +1382,7 @@
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
- stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip));
+ PUSHINT(*(FICL_INT *)(pVM->ip));
vmBranchRelative(pVM, 1);
return;
}
@@ -1295,8 +1392,8 @@
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 2);
#endif
- stackPushINT(pVM->pStack, *((FICL_INT *)(pVM->ip)+1));
- stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip));
+ PUSHINT(*((FICL_INT *)(pVM->ip)+1));
+ PUSHINT(*(FICL_INT *)(pVM->ip));
vmBranchRelative(pVM, 2);
return;
}
@@ -1381,7 +1478,7 @@
#endif
x = stackPop(pVM->pStack);
y = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, FICL_BOOL(x.i == y.i));
+ PUSHINT(FICL_BOOL(x.i == y.i));
return;
}
@@ -1393,7 +1490,7 @@
#endif
y = stackPop(pVM->pStack);
x = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, FICL_BOOL(x.i < y.i));
+ PUSHINT(FICL_BOOL(x.i < y.i));
return;
}
@@ -1405,7 +1502,7 @@
#endif
u2 = stackPopUNS(pVM->pStack);
u1 = stackPopUNS(pVM->pStack);
- stackPushINT(pVM->pStack, FICL_BOOL(u1 < u2));
+ PUSHINT(FICL_BOOL(u1 < u2));
return;
}
@@ -1417,7 +1514,7 @@
#endif
y = stackPop(pVM->pStack);
x = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i));
+ PUSHINT(FICL_BOOL(x.i > y.i));
return;
}
@@ -1429,7 +1526,7 @@
#endif
x = stackPop(pVM->pStack);
y = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, x.i & y.i);
+ PUSHINT(x.i & y.i);
return;
}
@@ -1441,7 +1538,7 @@
#endif
x = stackPop(pVM->pStack);
y = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, x.i | y.i);
+ PUSHINT(x.i | y.i);
return;
}
@@ -1453,7 +1550,7 @@
#endif
x = stackPop(pVM->pStack);
y = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, x.i ^ y.i);
+ PUSHINT(x.i ^ y.i);
return;
}
@@ -1464,7 +1561,7 @@
vmCheckStack(pVM, 1, 1);
#endif
x = stackPop(pVM->pStack);
- stackPushINT(pVM->pStack, ~x.i);
+ PUSHINT(~x.i);
return;
}
@@ -1654,13 +1751,19 @@
static void plusLoopParen(FICL_VM *pVM)
{- FICL_INT index = stackGetTop(pVM->rStack).i;
- FICL_INT limit = stackFetch(pVM->rStack, 1).i;
- FICL_INT increment = stackPop(pVM->pStack).i;
- int flag;
+ FICL_INT index,limit,increment;
+ int flag;
- index += increment;
+#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
@@ -1712,26 +1815,33 @@
r e t u r n s t a c k
**
**************************************************************************/
-
static void toRStack(FICL_VM *pVM)
{- stackPush(pVM->rStack, stackPop(pVM->pStack));
- return;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ stackPush(pVM->rStack, POP());
}
static void fromRStack(FICL_VM *pVM)
{- stackPush(pVM->pStack, stackPop(pVM->rStack));
- return;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ PUSH(stackPop(pVM->rStack));
}
static void fetchRStack(FICL_VM *pVM)
{- stackPush(pVM->pStack, stackGetTop(pVM->rStack));
- return;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ PUSH(stackGetTop(pVM->rStack));
}
-
static void twoToR(FICL_VM *pVM)
{#if FICL_ROBUST > 1
@@ -1756,6 +1866,9 @@
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;
@@ -1769,9 +1882,13 @@
static void variableParen(FICL_VM *pVM)
{- FICL_WORD *fw = pVM->runningWord;
- stackPushPtr(pVM->pStack, fw->param);
- return;
+ FICL_WORD *fw;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ fw = pVM->runningWord;
+ PUSHPTR(fw->param);
}
@@ -1804,9 +1921,13 @@
static void base(FICL_VM *pVM)
{- CELL *pBase = (CELL *)(&pVM->base);
- stackPush(pVM->pStack, LVALUEtoCELL(pBase));
- return;
+ CELL *pBase;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ pBase = (CELL *)(&pVM->base);
+ PUSH(*pBase);
}
@@ -1831,12 +1952,20 @@
static void allot(FICL_VM *pVM)
{- FICL_DICT *dp = ficlGetDict();
- FICL_INT i = stackPopINT(pVM->pStack);
+ FICL_DICT *dp;
+ FICL_INT i;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ dp = ficlGetDict();
+ i = POPINT();
+
#if FICL_ROBUST
- dictCheck(dp, pVM, (i+sizeof(CELL)-1)/sizeof(CELL));
+ dictCheck(dp, pVM, i);
#endif
- dictAllot(dp, i);
+
+ dictAllot(dp, i);
return;
}
@@ -1843,46 +1972,70 @@
static void here(FICL_VM *pVM)
{- FICL_DICT *dp = ficlGetDict();
- stackPushPtr(pVM->pStack, dp->here);
+ FICL_DICT *dp;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ dp = ficlGetDict();
+ PUSHPTR(dp->here);
return;
}
-
static void comma(FICL_VM *pVM)
{- FICL_DICT *dp = ficlGetDict();
- CELL c = stackPop(pVM->pStack);
- dictAppendCell(dp, c);
+ FICL_DICT *dp;
+ CELL c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ dp = ficlGetDict();
+ c = POP();
+ dictAppendCell(dp, c);
return;
}
-
static void cComma(FICL_VM *pVM)
{- FICL_DICT *dp = ficlGetDict();
- char c = (char)stackPopINT(pVM->pStack);
- dictAppendChar(dp, c);
+ FICL_DICT *dp;
+ char c;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ dp = ficlGetDict();
+ c = (char)POPINT();
+ dictAppendChar(dp, c);
return;
}
-
static void cells(FICL_VM *pVM)
{- FICL_INT i = stackPopINT(pVM->pStack);
- stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL));
+ 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 = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, cp + sizeof (CELL));
+ 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 )
@@ -1892,16 +2045,19 @@
**************************************************************************/
void ficlTick(FICL_VM *pVM)
{- FICL_WORD *pFW = NULL;
- STRINGINFO si = vmGetWord(pVM);
-
- pFW = dictLookup(ficlGetDict(), si);
- if (!pFW)
- {- int i = SI_COUNT(si);
- vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
- }
- stackPushPtr(pVM->pStack, pFW);
+ FICL_WORD *pFW = NULL;
+ STRINGINFO si = vmGetWord(pVM);
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ pFW = dictLookup(ficlGetDict(), si);
+ if (!pFW)
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
+ }
+ PUSHPTR(pFW);
return;
}
@@ -2001,15 +2157,21 @@
static void stringLit(FICL_VM *pVM)
{- FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
- FICL_COUNT count = sp->count;
- char *cp = sp->text;
- stackPushPtr(pVM->pStack, cp);
- stackPushUNS(pVM->pStack, count);
- cp += count + 1;
- cp = alignPtr(cp);
- pVM->ip = (IPTYPE)(void *)cp;
- return;
+ 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)
@@ -2030,6 +2192,9 @@
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;
@@ -2057,12 +2222,18 @@
**************************************************************************/
static void sLiteralCoIm(FICL_VM *pVM)
{- FICL_DICT *dp = ficlGetDict();
- char *cp, *cpDest;
- FICL_UNS u;
- u = stackPopUNS(pVM->pStack);
- cp = stackPopPtr(pVM->pStack);
+ FICL_DICT *dp;
+ char *cp, *cpDest;
+ FICL_UNS u;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
+
+ dp = ficlGetDict();
+ u = POPUNS();
+ cp = POPPTR();
+
dictAppendCell(dp, LVALUEtoCELL(pStringLit));
cpDest = (char *) dp->here;
*cpDest++ = (char) u;
@@ -2085,7 +2256,10 @@
**************************************************************************/
static void state(FICL_VM *pVM)
{- stackPushPtr(pVM->pStack, &pVM->state);
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+ PUSHPTR(&pVM->state);
return;
}
@@ -2099,8 +2273,14 @@
static void createParen(FICL_VM *pVM)
{- CELL *pCell = pVM->runningWord->param;
- stackPushPtr(pVM->pStack, pCell+1);
+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ pCell = pVM->runningWord->param;
+ PUSHPTR(pCell+1);
return;
}
@@ -2118,10 +2298,16 @@
static void doDoes(FICL_VM *pVM)
{- CELL *pCell = pVM->runningWord->param;
- IPTYPE tempIP = (IPTYPE)((*pCell).p);
- stackPushPtr(pVM->pStack, pCell+1);
- vmPushIP(pVM, tempIP);
+ 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;
}
@@ -2165,8 +2351,14 @@
**************************************************************************/
static void toBody(FICL_VM *pVM)
{- FICL_WORD *pFW = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, pFW->param + 1);
+ FICL_WORD *pFW;
+/*#$-GUY CHANGE: Added robustness.-$#*/
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+
+ pFW = POPPTR();
+ PUSHPTR(pFW->param + 1);
return;
}
@@ -2177,8 +2369,13 @@
*/
static void fromBody(FICL_VM *pVM)
{- char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD);
- stackPushPtr(pVM->pStack, ptr);
+ char *ptr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 1);
+#endif
+
+ ptr = (char *)POPPTR() - sizeof (FICL_WORD);
+ PUSHPTR(ptr);
return;
}
@@ -2190,9 +2387,14 @@
*/
static void toName(FICL_VM *pVM)
{- FICL_WORD *pFW = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, pFW->name);
- stackPushUNS(pVM->pStack, pFW->nName);
+ FICL_WORD *pFW;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 2);
+#endif
+
+ pFW = POPPTR();
+ PUSHPTR(pFW->name);
+ PUSHUNS(pFW->nName);
return;
}
@@ -2199,10 +2401,10 @@
static void getLastWord(FICL_VM *pVM)
{- FICL_DICT *pDict = ficlGetDict();
+ FICL_DICT *pDict = ficlGetDict();
FICL_WORD *wp = pDict->smudge;
assert(wp);
- vmPush(pVM, LVALUEtoCELL(wp));
+ vmPush(pVM, LVALUEtoCELL(wp));
return;
}
@@ -2250,14 +2452,18 @@
*/
static void numberSign(FICL_VM *pVM)
{- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- DPUNS u;
- UNS16 rem;
-
- u = u64Pop(pVM->pStack);
- rem = m64UMod(&u, (UNS16)(pVM->base));
- sp->text[sp->count++] = digit_to_char(rem);
- u64Push(pVM->pStack, u);
+ 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;
}
@@ -2269,12 +2475,17 @@
*/
static void numberSignGreater(FICL_VM *pVM)
{- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- sp->text[sp->count] = '\0';
- strrev(sp->text);
- stackDrop(pVM->pStack, 2);
- stackPushPtr(pVM->pStack, sp->text);
- stackPushUNS(pVM->pStack, sp->count);
+ 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;
}
@@ -2287,20 +2498,24 @@
*/
static void numberSignS(FICL_VM *pVM)
{- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- DPUNS u;
- UNS16 rem;
+ FICL_STRING *sp;
+ DPUNS u;
+ UNS16 rem;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 2);
+#endif
- u = u64Pop(pVM->pStack);
+ 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);
+ do
+ {+ rem = m64UMod(&u, (UNS16)(pVM->base));
+ sp->text[sp->count++] = digit_to_char(rem);
+ }
+ while (u.hi || u.lo);
- u64Push(pVM->pStack, u);
+ u64Push(pVM->pStack, u);
return;
}
@@ -2311,9 +2526,15 @@
*/
static void hold(FICL_VM *pVM)
{- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- int i = stackPopINT(pVM->pStack);
- sp->text[sp->count++] = (char) i;
+ 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;
}
@@ -2325,10 +2546,16 @@
*/
static void sign(FICL_VM *pVM)
{- FICL_STRING *sp = PTRtoSTRING pVM->pad;
- int i = stackPopINT(pVM->pStack);
- if (i < 0)
- sp->text[sp->count++] = '-';
+ 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;
}
@@ -2349,13 +2576,19 @@
**************************************************************************/
static void toNumber(FICL_VM *pVM)
{- FICL_UNS count = stackPopUNS(pVM->pStack);
- char *cp = (char *)stackPopPtr(pVM->pStack);
- DPUNS accum;
- FICL_UNS base = pVM->base;
- FICL_UNS ch;
- FICL_UNS digit;
+ 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--)
@@ -2378,8 +2611,8 @@
}
u64Push(pVM->pStack, accum);
- stackPushPtr (pVM->pStack, cp);
- stackPushUNS(pVM->pStack, count);
+ PUSHPTR(cp);
+ PUSHUNS(count);
return;
}
@@ -2436,12 +2669,17 @@
**************************************************************************/
static void accept(FICL_VM *pVM)
{- FICL_INT count;
- char *cp;
- char *pBuf = vmGetInBuf(pVM);
- char *pEnd = vmGetInBufEnd(pVM);
- FICL_INT len = pEnd - pBuf;
+ 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);
@@ -2455,7 +2693,7 @@
strncpy(cp, vmGetInBuf(pVM), len);
pBuf += len;
vmUpdateTib(pVM, pBuf);
- stackPushINT(pVM->pStack, len);
+ PUSHINT(len);
return;
}
@@ -2482,8 +2720,13 @@
**************************************************************************/
static void aligned(FICL_VM *pVM)
{- void *addr = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, alignPtr(addr));
+ void *addr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,1);
+#endif
+
+ addr = POPPTR();
+ PUSHPTR(alignPtr(addr));
return;
}
@@ -2572,9 +2815,13 @@
**************************************************************************/
static void ficlChar(FICL_VM *pVM)
{- STRINGINFO si = vmGetWord(pVM);
- stackPushUNS(pVM->pStack, (FICL_UNS)(si.cp[0]));
+ STRINGINFO si;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,0,1);
+#endif
+ si = vmGetWord(pVM);
+ PUSHUNS((FICL_UNS)(si.cp[0]));
return;
}
@@ -2592,8 +2839,13 @@
**************************************************************************/
static void charPlus(FICL_VM *pVM)
{- char *cp = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, cp + 1);
+ char *cp;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,1);
+#endif
+
+ cp = POPPTR();
+ PUSHPTR(cp + 1);
return;
}
@@ -2609,12 +2861,16 @@
#endif
static void ficlChars(FICL_VM *pVM)
{- if (sizeof (char) > 1)
- {- FICL_INT i = stackPopINT(pVM->pStack);
- stackPushINT(pVM->pStack, i * sizeof (char));
- }
- /* otherwise no-op! */
+ 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)
@@ -2632,9 +2888,14 @@
**************************************************************************/
static void count(FICL_VM *pVM)
{- FICL_STRING *sp = stackPopPtr(pVM->pStack);
- stackPushPtr(pVM->pStack, sp->text);
- stackPushUNS(pVM->pStack, sp->count);
+ FICL_STRING *sp;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,2);
+#endif
+
+ sp = POPPTR();
+ PUSHPTR(sp->text);
+ PUSHUNS(sp->count);
return;
}
@@ -2653,27 +2914,32 @@
**************************************************************************/
static void environmentQ(FICL_VM *pVM)
{- FICL_DICT *envp = ficlGetEnv();
- FICL_COUNT len = (FICL_COUNT)stackPopUNS(pVM->pStack);
- char *cp = stackPopPtr(pVM->pStack);
- FICL_WORD *pFW;
- STRINGINFO si;
+ FICL_DICT *envp;
+ FICL_COUNT len;
+ char *cp;
+ FICL_WORD *pFW;
+ STRINGINFO si;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
+ envp = ficlGetEnv();
+ len = (FICL_COUNT)POPUNS();
+ cp = POPPTR();
- &len; /* silence compiler warning... */
- SI_PSZ(si, cp);
- pFW = dictLookup(envp, si);
+ IGNORE(len);
+ SI_PSZ(si, cp);
+ pFW = dictLookup(envp, si);
- if (pFW != NULL)
- {- vmExecute(pVM, pFW);
- stackPushINT(pVM->pStack, FICL_TRUE);
- }
- else
- {- stackPushINT(pVM->pStack, FICL_FALSE);
- }
-
+ if (pFW != NULL)
+ {+ vmExecute(pVM, pFW);
+ PUSHINT(FICL_TRUE);
+ }
+ else
+ {+ PUSHINT(FICL_FALSE);
+ }
return;
}
@@ -2689,18 +2955,25 @@
**************************************************************************/
static void evaluate(FICL_VM *pVM)
{- FICL_INT count = stackPopINT(pVM->pStack);
- char *cp = stackPopPtr(pVM->pStack);
- CELL id;
+ FICL_UNS count;
+ char *cp;
+ CELL id;
int result;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,0);
+#endif
- id = pVM->sourceID;
- pVM->sourceID.i = -1;
- result = ficlExecC(pVM, cp, count);
- pVM->sourceID = id;
- if (result != VM_OUTOFTEXT)
- vmThrow(pVM, result);
+ 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;
}
@@ -2707,7 +2980,7 @@
/**************************************************************************
s t r i n g q u o t e
-** Intrpreting: get string delimited by a quote from the input stream,
+** 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
@@ -2721,8 +2994,8 @@
{FICL_STRING *sp = (FICL_STRING *) dp->here;
vmGetString(pVM, sp, '\"');
- stackPushPtr(pVM->pStack, sp->text);
- stackPushUNS(pVM->pStack, sp->count);
+ PUSHPTR(sp->text);
+ PUSHUNS(sp->count);
}
else /* COMPILE state */
{@@ -2741,25 +3014,31 @@
**************************************************************************/
static void type(FICL_VM *pVM)
{- FICL_UNS count = stackPopUNS(pVM->pStack);
- char *cp = stackPopPtr(pVM->pStack);
+ FICL_UNS count;
+ char *cp;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 2, 0);
+#endif
- /*
- ** 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 *)ficlGetDict()->here;
- if (cp != pDest)
- strncpy(pDest, cp, count);
+ count = POPUNS();
+ cp = POPPTR();
- pDest[count] = '\0';
- cp = pDest;
- }
+ /*
+ ** 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 *)ficlGetDict()->here;
+ if (cp != pDest)
+ strncpy(pDest, cp, count);
- vmTextOut(pVM, cp, 0);
+ pDest[count] = '\0';
+ cp = pDest;
+ }
+
+ vmTextOut(pVM, cp, 0);
return;
}
@@ -2779,20 +3058,27 @@
**************************************************************************/
static void ficlWord(FICL_VM *pVM)
{- FICL_STRING *sp = (FICL_STRING *)pVM->pad;
- char delim = (char)stackPopINT(pVM->pStack);
- STRINGINFO si;
-
+ 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);
+ 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));
- strcat(sp->text, " ");
+ 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, " ");
- stackPushPtr(pVM->pStack, sp);
+ PUSHPTR(sp);
return;
}
@@ -2806,9 +3092,14 @@
**************************************************************************/
static void parseNoCopy(FICL_VM *pVM)
{- STRINGINFO si = vmGetWord0(pVM);
- stackPushPtr(pVM->pStack, SI_PTR(si));
- stackPushUNS(pVM->pStack, SI_COUNT(si));
+ STRINGINFO si;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,0,2);
+#endif
+
+ si = vmGetWord0(pVM);
+ PUSHPTR(SI_PTR(si));
+ PUSHUNS(SI_COUNT(si));
return;
}
@@ -2824,12 +3115,18 @@
**************************************************************************/
static void parse(FICL_VM *pVM)
{- STRINGINFO si;
- char delim = (char)stackPopINT(pVM->pStack);
+ STRINGINFO si;
+ char delim;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,2);
+#endif
+
+ delim = (char)POPINT();
+
si = vmParseStringEx(pVM, delim, 0);
- stackPushPtr(pVM->pStack, SI_PTR(si));
- stackPushUNS(pVM->pStack, SI_COUNT(si));
+ PUSHPTR(SI_PTR(si));
+ PUSHUNS(SI_COUNT(si));
return;
}
@@ -2842,16 +3139,21 @@
**************************************************************************/
static void fill(FICL_VM *pVM)
{- char ch = (char)stackPopINT(pVM->pStack);
- FICL_UNS u = stackPopUNS(pVM->pStack);
- char *cp = (char *)stackPopPtr(pVM->pStack);
+ 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--;
- }
-
+ while (u > 0)
+ {+ *cp++ = ch;
+ u--;
+ }
return;
}
@@ -2868,22 +3170,26 @@
**************************************************************************/
static void find(FICL_VM *pVM)
{- FICL_STRING *sp = stackPopPtr(pVM->pStack);
- FICL_WORD *pFW;
- STRINGINFO si;
+ FICL_STRING *sp;
+ FICL_WORD *pFW;
+ STRINGINFO si;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,2);
+#endif
- SI_PFS(si, sp);
- pFW = dictLookup(ficlGetDict(), si);
- if (pFW)
- {- stackPushPtr(pVM->pStack, pFW);
- stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
- }
- else
- {- stackPushPtr(pVM->pStack, sp);
- stackPushUNS(pVM->pStack, 0);
- }
+ sp = POPPTR();
+ SI_PFS(si, sp);
+ pFW = dictLookup(ficlGetDict(), si);
+ if (pFW)
+ {+ PUSHPTR(pFW);
+ PUSHINT((wordIsImmediate(pFW) ? 1 : -1));
+ }
+ else
+ {+ PUSHPTR(sp);
+ PUSHUNS(0);
+ }
return;
}
@@ -2899,15 +3205,18 @@
**************************************************************************/
static void fmSlashMod(FICL_VM *pVM)
{- DPINT d1;
- FICL_INT n1;
- INTQR qr;
+ DPINT d1;
+ FICL_INT n1;
+ INTQR qr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,3,2);
+#endif
- n1 = stackPopINT(pVM->pStack);
- d1 = i64Pop(pVM->pStack);
- qr = m64FlooredDivI(d1, n1);
- stackPushINT(pVM->pStack, qr.rem);
- stackPushINT(pVM->pStack, qr.quot);
+ n1 = POPINT();
+ d1 = i64Pop(pVM->pStack);
+ qr = m64FlooredDivI(d1, n1);
+ PUSHINT(qr.rem);
+ PUSHINT(qr.quot);
return;
}
@@ -2922,15 +3231,18 @@
**************************************************************************/
static void smSlashRem(FICL_VM *pVM)
{- DPINT d1;
- FICL_INT n1;
- INTQR qr;
+ DPINT d1;
+ FICL_INT n1;
+ INTQR qr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,3,2);
+#endif
- n1 = stackPopINT(pVM->pStack);
- d1 = i64Pop(pVM->pStack);
- qr = m64SymmetricDivI(d1, n1);
- stackPushINT(pVM->pStack, qr.rem);
- stackPushINT(pVM->pStack, qr.quot);
+ n1 = POPINT();
+ d1 = i64Pop(pVM->pStack);
+ qr = m64SymmetricDivI(d1, n1);
+ PUSHINT(qr.rem);
+ PUSHINT(qr.quot);
return;
}
@@ -2937,15 +3249,18 @@
static void ficlMod(FICL_VM *pVM)
{- DPINT d1;
- FICL_INT n1;
- INTQR qr;
+ DPINT d1;
+ FICL_INT n1;
+ INTQR qr;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
- n1 = stackPopINT(pVM->pStack);
- d1.lo = stackPopINT(pVM->pStack);
- i64Extend(d1);
- qr = m64SymmetricDivI(d1, n1);
- stackPushINT(pVM->pStack, qr.rem);
+ n1 = POPINT();
+ d1.lo = POPINT();
+ i64Extend(d1);
+ qr = m64SymmetricDivI(d1, n1);
+ PUSHINT(qr.rem);
return;
}
@@ -2967,8 +3282,8 @@
u1 = stackPopUNS(pVM->pStack);
ud = u64Pop(pVM->pStack);
qr = ficlLongDiv(ud, u1);
- stackPushUNS(pVM->pStack, qr.rem);
- stackPushUNS(pVM->pStack, qr.quot);
+ PUSHUNS(qr.rem);
+ PUSHUNS(qr.quot);
return;
}
@@ -2989,10 +3304,15 @@
**************************************************************************/
static void lshift(FICL_VM *pVM)
{- FICL_UNS nBits = stackPopUNS(pVM->pStack);
- FICL_UNS x1 = stackPopUNS(pVM->pStack);
+ FICL_UNS nBits;
+ FICL_UNS x1;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
- stackPushUNS(pVM->pStack, x1 << nBits);
+ nBits = POPUNS();
+ x1 = POPUNS();
+ PUSHUNS(x1 << nBits);
return;
}
@@ -2999,10 +3319,16 @@
static void rshift(FICL_VM *pVM)
{- FICL_UNS nBits = stackPopUNS(pVM->pStack);
- FICL_UNS x1 = stackPopUNS(pVM->pStack);
+ FICL_UNS nBits;
+ FICL_UNS x1;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
- stackPushUNS(pVM->pStack, x1 >> nBits);
+ nBits = POPUNS();
+ x1 = POPUNS();
+
+ PUSHUNS(x1 >> nBits);
return;
}
@@ -3014,12 +3340,18 @@
**************************************************************************/
static void mStar(FICL_VM *pVM)
{- FICL_INT n2 = stackPopINT(pVM->pStack);
- FICL_INT n1 = stackPopINT(pVM->pStack);
- DPINT d;
-
- d = m64MulI(n1, n2);
- i64Push(pVM->pStack, d);
+ 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;
}
@@ -3026,12 +3358,18 @@
static void umStar(FICL_VM *pVM)
{- FICL_UNS u2 = stackPopUNS(pVM->pStack);
- FICL_UNS u1 = stackPopUNS(pVM->pStack);
- DPUNS ud;
-
- ud = ficlLongMul(u1, u2);
- u64Push(pVM->pStack, ud);
+ 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;
}
@@ -3042,19 +3380,31 @@
**************************************************************************/
static void ficlMax(FICL_VM *pVM)
{- FICL_INT n2 = stackPopINT(pVM->pStack);
- FICL_INT n1 = stackPopINT(pVM->pStack);
+ FICL_INT n2;
+ FICL_INT n1;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
- stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2);
+ n2 = POPINT();
+ n1 = POPINT();
+
+ PUSHINT((n1 > n2) ? n1 : n2);
return;
}
static void ficlMin(FICL_VM *pVM)
{- FICL_INT n2 = stackPopINT(pVM->pStack);
- FICL_INT n1 = stackPopINT(pVM->pStack);
+ FICL_INT n2;
+ FICL_INT n1;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,1);
+#endif
- stackPushINT(pVM->pStack, (n1 < n2) ? n1 : n2);
+ n2 = POPINT();
+ n1 = POPINT();
+
+ PUSHINT((n1 < n2) ? n1 : n2);
return;
}
@@ -3071,10 +3421,17 @@
**************************************************************************/
static void move(FICL_VM *pVM)
{- FICL_UNS u = stackPopUNS(pVM->pStack);
- char *addr2 = stackPopPtr(pVM->pStack);
- char *addr1 = stackPopPtr(pVM->pStack);
+ 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;
/*
@@ -3120,11 +3477,16 @@
**************************************************************************/
static void sToD(FICL_VM *pVM)
{- FICL_INT s = stackPopINT(pVM->pStack);
+ FICL_INT s;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,1,2);
+#endif
- /* sign extend to 64 bits.. */
- stackPushINT(pVM->pStack, s);
- stackPushINT(pVM->pStack, (s < 0) ? -1 : 0);
+ s = POPINT();
+
+ /* sign extend to 64 bits.. */
+ PUSHINT(s);
+ PUSHINT((s < 0) ? -1 : 0);
return;
}
@@ -3137,8 +3499,11 @@
**************************************************************************/
static void source(FICL_VM *pVM)
{- stackPushPtr(pVM->pStack, pVM->tib.cp);
- stackPushINT(pVM->pStack, vmGetInBufLen(pVM));
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,0,2);
+#endif
+ PUSHPTR(pVM->tib.cp);
+ PUSHINT(vmGetInBufLen(pVM));
return;
}
@@ -3160,7 +3525,10 @@
**************************************************************************/
static void toIn(FICL_VM *pVM)
{- stackPushPtr(pVM->pStack, &pVM->tib.index);
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,0,1);
+#endif
+ PUSHPTR(&pVM->tib.index);
return;
}
@@ -3182,7 +3550,7 @@
pVM->state = COMPILE;
pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
- stackPushPtr(pVM->pStack, pFW);
+ PUSHPTR(pFW);
markControlTag(pVM, colonTag);
return;
}
@@ -3208,7 +3576,7 @@
static void userParen(FICL_VM *pVM)
{FICL_INT i = pVM->runningWord->param[0].i;
- stackPushPtr(pVM->pStack, &pVM->user[i]);
+ PUSHPTR(&pVM->user[i]);
return;
}
@@ -3257,12 +3625,12 @@
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
}
- else if (pFW && pFW->code == do2LocalIm)
- {+ else if (pFW && pFW->code == do2LocalIm)
+ {dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen));
dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
return;
- }
+ }
}
#endif
@@ -3279,7 +3647,7 @@
pFW->param[0] = stackPop(pVM->pStack);
else /* compile code to store to word's param */
{- stackPushPtr(pVM->pStack, &pFW->param[0]);
+ PUSHPTR(&pFW->param[0]);
literalIm(pVM);
dictAppendCell(dp, LVALUEtoCELL(pStore));
}
@@ -3424,11 +3792,17 @@
**************************************************************************/
static void localParen(FICL_VM *pVM)
{- FICL_DICT *pDict = ficlGetDict();
- STRINGINFO si;
- SI_SETLEN(si, stackPopUNS(pVM->pStack));
- SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
+ static CELL *pMark = NULL;
+ FICL_DICT *pDict;
+ STRINGINFO si;
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,2,0);
+#endif
+ pDict = ficlGetDict();
+ 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();
@@ -3533,7 +3907,7 @@
dictAppendCell(pDict, LVALUEtoCELL(nLocals));
}
- dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
+ dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
dictAppendCell(pDict, LVALUEtoCELL(nLocals));
nLocals += 2;
@@ -3588,7 +3962,7 @@
else if (n > 0)
n = 1;
- stackPushINT(pVM->pStack, n);
+ PUSHINT(n);
return;
}
@@ -3606,7 +3980,7 @@
**************************************************************************/
static void sourceid(FICL_VM *pVM)
{- stackPushINT(pVM->pStack, pVM->sourceID.i);
+ PUSHINT(pVM->sourceID.i);
return;
}
@@ -3630,7 +4004,7 @@
if (ret && (pVM->fRestart == 0))
vmThrow(pVM, VM_RESTART);
- stackPushINT(pVM->pStack, ret);
+ PUSHINT(ret);
return;
}
@@ -3711,41 +4085,41 @@
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, &pQuit); /* Open mouth, insert emetic */
+ {+ /*
+ ** 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, &pQuit); /* Open mouth, insert emetic */
vmExecute(pVM, pFW);
vmInnerLoop(pVM);
- break;
+ break;
- /*
- ** Normal exit from XT - lose the poison pill,
- ** restore old setjmp vector and push a zero.
- */
- case VM_INNEREXIT:
+ /*
+ ** 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 */
- stackPushINT(pVM->pStack, 0); /* Push 0 -- everything is ok */
- break;
+ PUSHINT(0); /* Push 0 -- everything is ok */
+ break;
- /*
- ** Some other exception got thrown - restore pre-existing VM state
- ** and push the exception code
- */
- default:
+ /*
+ ** 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));
- stackPushINT(pVM->pStack, except);/* Push error */
- break;
- }
+ PUSHINT(except);/* Push error */
+ break;
+ }
}
/**************************************************************************
@@ -3781,11 +4155,11 @@
size = stackPopINT(pVM->pStack);
p = ficlMalloc(size);
- stackPushPtr(pVM->pStack, p);
+ PUSHPTR(p);
if (p)
- stackPushINT(pVM->pStack, 0);
+ PUSHINT(0);
else
- stackPushINT(pVM->pStack, 1);
+ PUSHINT(1);
}
@@ -3799,7 +4173,7 @@
p = stackPopPtr(pVM->pStack);
ficlFree(p);
- stackPushINT(pVM->pStack, 0);
+ PUSHINT(0);
}
@@ -3817,13 +4191,13 @@
new = ficlRealloc(old, size);
if (new)
{- stackPushPtr(pVM->pStack, new);
- stackPushINT(pVM->pStack, 0);
+ PUSHPTR(new);
+ PUSHINT(0);
}
else
{- stackPushPtr(pVM->pStack, old);
- stackPushINT(pVM->pStack, 1);
+ PUSHPTR(old);
+ PUSHINT(1);
}
}
@@ -3875,41 +4249,41 @@
WORDKIND ficlWordClassify(FICL_WORD *pFW)
{typedef struct
- {- WORDKIND kind;
- FICL_CODE code;
- } CODEtoKIND;
+ {+ 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},- {STRINGLIT, stringLit},- {USER, userParen},- {VARIABLE, variableParen},- };
+ 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},+ {STRINGLIT, stringLit},+ {USER, userParen},+ {VARIABLE, variableParen},+ };
#define nMAP (sizeof(codeMap) / sizeof(CODEtoKIND))
FICL_CODE code = pFW->code;
- int i;
+ int i;
- for (i=0; i < nMAP; i++)
- {- if (codeMap[i].code == code)
- return codeMap[i].kind;
- }
+ for (i=0; i < nMAP; i++)
+ {+ if (codeMap[i].code == code)
+ return codeMap[i].kind;
+ }
- return PRIMITIVE;
+ return PRIMITIVE;
}
@@ -3918,8 +4292,9 @@
** Builds the primitive wordset and the environment-query namespace.
**************************************************************************/
-void ficlCompileCore(FICL_DICT *dp)
+void ficlCompileCore(FICL_SYSTEM *pSys)
{+ FICL_DICT *dp = pSys->dp;
assert (dp);
/*
@@ -4074,7 +4449,7 @@
dictAppendWord(dp, "pick", pick, FW_DEFAULT);
dictAppendWord(dp, "roll", roll, FW_DEFAULT);
dictAppendWord(dp, "refill", refill, FW_DEFAULT);
- dictAppendWord(dp, "source-id", sourceid, 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);
@@ -4162,15 +4537,15 @@
ficlSetEnv("memory-alloc", FICL_TRUE); ficlSetEnv("memory-alloc-ext", FICL_FALSE);- /*
+ /*
** optional SEARCH-ORDER word set
*/
- ficlCompileSearch(dp);
+ ficlCompileSearch(pSys);
/*
** TOOLS and TOOLS EXT
*/
- ficlCompileTools(dp);
+ ficlCompileTools(pSys);
/*
** Ficl extras
@@ -4179,6 +4554,8 @@
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, "compile-only",
@@ -4185,8 +4562,7 @@
compileOnly, FW_DEFAULT);
dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED);
dictAppendWord(dp, "last-word", getLastWord, FW_DEFAULT);
- dictAppendWord(dp, "hash", hash, FW_DEFAULT);
- dictAppendWord(dp, "number?", ficlIsNum, FW_DEFAULT);
+ dictAppendWord(dp, "hash", hash, FW_DEFAULT);
dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT);
dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */
dictAppendWord(dp, "q@", quadFetch, FW_DEFAULT);
@@ -4201,6 +4577,7 @@
/*
** internal support words
*/
+ dictAppendWord(dp, "(create)", createParen, FW_COMPILE);
pExitParen =
dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE);
pSemiParen =
@@ -4229,6 +4606,8 @@
dictAppendWord(dp, "interpret", interpret, FW_DEFAULT);
dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE);
dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE);
+ dictAppendWord(dp, "(parse-step)",
+ parseStepParen, FW_DEFAULT);
dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT);
assert(dictCellsAvail(dp) > 0);