Fix white spaces.

Convert tabs to spaces.
Remove trailing whitespaces.
Convert EOL to LF.
No real code changes.

diff --git a/csrc/pf_all.h b/csrc/pf_all.h
index 560b287..8d3ff6f 100644 (file)
--- a/csrc/pf_all.h
+++ b/csrc/pf_all.h
@@ -1,67 +1,67 @@
-/* @(#) pf_all.h 98/01/26 1.2 */\r
-\r
-#ifndef _pf_all_h\r
-#define _pf_all_h\r
-\r
-/***************************************************************\r
-** Include all files needed for PForth\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-** 940521 PLB Creation.\r
-**\r
-***************************************************************/\r
-\r
-#ifdef PF_EMBEDDED\r
-       #define PF_NO_INIT\r
-       #define PF_NO_STDIO\r
-       #define PF_NO_MALLOC\r
-       #define PF_NO_CLIB\r
-       #define PF_NO_FILEIO\r
-#endif\r
-\r
-/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */\r
-#ifdef __MWERKS__\r
-       #define PF_SUPPORT_FP    (1)\r
-#endif\r
-\r
-#ifdef WIN32\r
-       #define PF_USER_INC2     "pf_win32.h"\r
-#endif\r
-\r
-#if defined(PF_USER_INC1)\r
-       #include PF_USER_INC1\r
-#else\r
-       #include "pf_inc1.h"\r
-#endif\r
-\r
-#include "pforth.h"\r
-#include "pf_types.h"\r
-#include "pf_io.h"\r
-#include "pf_guts.h"\r
-#include "pf_text.h"\r
-#include "pfcompil.h"\r
-#include "pf_clib.h"\r
-#include "pf_words.h"\r
-#include "pf_save.h"\r
-#include "pf_mem.h"\r
-#include "pf_cglue.h"\r
-#include "pf_core.h"\r
-\r
-#ifdef PF_USER_INC2\r
-/* This could be used to undef and redefine macros. */\r
-       #include PF_USER_INC2\r
-#endif\r
-\r
-#endif /* _pf_all_h */\r
-\r
+/* @(#) pf_all.h 98/01/26 1.2 */
+
+#ifndef _pf_all_h
+#define _pf_all_h
+
+/***************************************************************
+** Include all files needed for PForth
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+** 940521 PLB Creation.
+**
+***************************************************************/
+
+#ifdef PF_EMBEDDED
+    #define PF_NO_INIT
+    #define PF_NO_STDIO
+    #define PF_NO_MALLOC
+    #define PF_NO_CLIB
+    #define PF_NO_FILEIO
+#endif
+
+/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */
+#ifdef __MWERKS__
+    #define PF_SUPPORT_FP    (1)
+#endif
+
+#ifdef WIN32
+    #define PF_USER_INC2     "pf_win32.h"
+#endif
+
+#if defined(PF_USER_INC1)
+    #include PF_USER_INC1
+#else
+    #include "pf_inc1.h"
+#endif
+
+#include "pforth.h"
+#include "pf_types.h"
+#include "pf_io.h"
+#include "pf_guts.h"
+#include "pf_text.h"
+#include "pfcompil.h"
+#include "pf_clib.h"
+#include "pf_words.h"
+#include "pf_save.h"
+#include "pf_mem.h"
+#include "pf_cglue.h"
+#include "pf_core.h"
+
+#ifdef PF_USER_INC2
+/* This could be used to undef and redefine macros. */
+    #include PF_USER_INC2
+#endif
+
+#endif /* _pf_all_h */
+

diff --git a/csrc/pf_cglue.c b/csrc/pf_cglue.c
index 0ec1e70..d70851e 100644 (file)
--- a/csrc/pf_cglue.c
+++ b/csrc/pf_cglue.c
@@ -1,100 +1,100 @@
-/* @(#) pf_cglue.c 98/02/11 1.4 */\r
-/***************************************************************\r
-** 'C' Glue support for Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-extern CFunc0 CustomFunctionTable[];\r
-\r
-/***************************************************************/\r
-cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams )\r
-{\r
-       cell_t P1, P2, P3, P4, P5;\r
-       cell_t Result = 0;\r
-       CFunc0 CF;\r
-\r
-DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n",\r
-       Index, ReturnMode, NumParams ));\r
-\r
-       CF = CustomFunctionTable[Index];\r
-       \r
-       switch( NumParams )\r
-       {\r
-       case 0:\r
-               Result = ((CFunc0) CF) ( );\r
-               break;\r
-       case 1:\r
-               P1 = POP_DATA_STACK;\r
-               Result = ((CFunc1) CF) ( P1 );\r
-               break;\r
-       case 2:\r
-               P2 = POP_DATA_STACK;\r
-               P1 = POP_DATA_STACK;\r
-               Result = ((CFunc2) CF) ( P1, P2 );\r
-               break;\r
-       case 3:\r
-               P3 = POP_DATA_STACK;\r
-               P2 = POP_DATA_STACK;\r
-               P1 = POP_DATA_STACK;\r
-               Result = ((CFunc3) CF) ( P1, P2, P3 );\r
-               break;\r
-       case 4:\r
-               P4 = POP_DATA_STACK;\r
-               P3 = POP_DATA_STACK;\r
-               P2 = POP_DATA_STACK;\r
-               P1 = POP_DATA_STACK;\r
-               Result = ((CFunc4) CF) ( P1, P2, P3, P4 );\r
-               break;\r
-       case 5:\r
-               P5 = POP_DATA_STACK;\r
-               P4 = POP_DATA_STACK;\r
-               P3 = POP_DATA_STACK;\r
-               P2 = POP_DATA_STACK;\r
-               P1 = POP_DATA_STACK;\r
-               Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 );\r
-               break;\r
-       default:\r
-               pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS);\r
-               EXIT(1);\r
-       }\r
-\r
-/* Push result on Forth stack if requested. */\r
-       if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result );\r
-\r
-       return Result;\r
-}\r
-\r
-#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
-/***************************************************************/\r
-Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams )\r
-{\r
-       ucell_t Packed;\r
-       char FName[40];\r
-       \r
-       CStringToForth( FName, CName, sizeof(FName) );\r
-       Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) |\r
-               (ReturnMode << 31);\r
-       DBUG(("Packed = 0x%8x\n", Packed));\r
-\r
-       ffCreateSecondaryHeader( FName );\r
-       CODE_COMMA( ID_CALL_C );\r
-       CODE_COMMA(Packed);\r
-       ffFinishSecondary();\r
-\r
-       return 0;\r
-}\r
-#endif\r
+/* @(#) pf_cglue.c 98/02/11 1.4 */
+/***************************************************************
+** 'C' Glue support for Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#include "pf_all.h"
+
+extern CFunc0 CustomFunctionTable[];
+
+/***************************************************************/
+cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams )
+{
+    cell_t P1, P2, P3, P4, P5;
+    cell_t Result = 0;
+    CFunc0 CF;
+
+DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n",
+    Index, ReturnMode, NumParams ));
+
+    CF = CustomFunctionTable[Index];
+
+    switch( NumParams )
+    {
+    case 0:
+        Result = ((CFunc0) CF) ( );
+        break;
+    case 1:
+        P1 = POP_DATA_STACK;
+        Result = ((CFunc1) CF) ( P1 );
+        break;
+    case 2:
+        P2 = POP_DATA_STACK;
+        P1 = POP_DATA_STACK;
+        Result = ((CFunc2) CF) ( P1, P2 );
+        break;
+    case 3:
+        P3 = POP_DATA_STACK;
+        P2 = POP_DATA_STACK;
+        P1 = POP_DATA_STACK;
+        Result = ((CFunc3) CF) ( P1, P2, P3 );
+        break;
+    case 4:
+        P4 = POP_DATA_STACK;
+        P3 = POP_DATA_STACK;
+        P2 = POP_DATA_STACK;
+        P1 = POP_DATA_STACK;
+        Result = ((CFunc4) CF) ( P1, P2, P3, P4 );
+        break;
+    case 5:
+        P5 = POP_DATA_STACK;
+        P4 = POP_DATA_STACK;
+        P3 = POP_DATA_STACK;
+        P2 = POP_DATA_STACK;
+        P1 = POP_DATA_STACK;
+        Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 );
+        break;
+    default:
+        pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS);
+        EXIT(1);
+    }
+
+/* Push result on Forth stack if requested. */
+    if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result );
+
+    return Result;
+}
+
+#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
+/***************************************************************/
+Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams )
+{
+    ucell_t Packed;
+    char FName[40];
+
+    CStringToForth( FName, CName, sizeof(FName) );
+    Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) |
+        (ReturnMode << 31);
+    DBUG(("Packed = 0x%8x\n", Packed));
+
+    ffCreateSecondaryHeader( FName );
+    CODE_COMMA( ID_CALL_C );
+    CODE_COMMA(Packed);
+    ffFinishSecondary();
+
+    return 0;
+}
+#endif

diff --git a/csrc/pf_cglue.h b/csrc/pf_cglue.h
index c3ddc87..4f82da1 100644 (file)
--- a/csrc/pf_cglue.h
+++ b/csrc/pf_cglue.h
@@ -1,45 +1,45 @@
-/* @(#) pf_cglue.h 96/12/18 1.7 */\r
-#ifndef _pf_c_glue_h\r
-#define _pf_c_glue_h\r
-\r
-/***************************************************************\r
-** Include file for PForth 'C' Glue support\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-typedef cell_t (*CFunc0)( void );\r
-typedef cell_t (*CFunc1)( cell_t P1 );\r
-typedef cell_t (*CFunc2)( cell_t P1, cell_t P2 );\r
-typedef cell_t (*CFunc3)( cell_t P1, cell_t P2, cell_t P3 );\r
-typedef cell_t (*CFunc4)( cell_t P1, cell_t P2, cell_t P3, cell_t P4 );\r
-typedef cell_t (*CFunc5)( cell_t P1, cell_t P2, cell_t P3, cell_t P4, cell_t P5 );\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-Err   CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams );\r
-Err   CompileCustomFunctions( void );\r
-Err   LoadCustomFunctionTable( void );\r
-cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams );\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#define C_RETURNS_VOID (0)\r
-#define C_RETURNS_VALUE (1)\r
-\r
-#endif /* _pf_c_glue_h */\r
+/* @(#) pf_cglue.h 96/12/18 1.7 */
+#ifndef _pf_c_glue_h
+#define _pf_c_glue_h
+
+/***************************************************************
+** Include file for PForth 'C' Glue support
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+typedef cell_t (*CFunc0)( void );
+typedef cell_t (*CFunc1)( cell_t P1 );
+typedef cell_t (*CFunc2)( cell_t P1, cell_t P2 );
+typedef cell_t (*CFunc3)( cell_t P1, cell_t P2, cell_t P3 );
+typedef cell_t (*CFunc4)( cell_t P1, cell_t P2, cell_t P3, cell_t P4 );
+typedef cell_t (*CFunc5)( cell_t P1, cell_t P2, cell_t P3, cell_t P4, cell_t P5 );
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+Err   CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams );
+Err   CompileCustomFunctions( void );
+Err   LoadCustomFunctionTable( void );
+cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams );
+
+#ifdef __cplusplus
+}
+#endif
+
+#define C_RETURNS_VOID (0)
+#define C_RETURNS_VALUE (1)
+
+#endif /* _pf_c_glue_h */

diff --git a/csrc/pf_clib.c b/csrc/pf_clib.c
index 0299c3b..d7212f0 100644 (file)
--- a/csrc/pf_clib.c
+++ b/csrc/pf_clib.c
@@ -1,64 +1,64 @@
-/* @(#) pf_clib.c 96/12/18 1.12 */\r
-/***************************************************************\r
-** Duplicate functions from stdlib for PForth based on 'C'\r
-**\r
-** This code duplicates some of the code in the 'C' lib\r
-** because it reduces the dependency on foreign libraries\r
-** for monitor mode where no OS is available.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 961124 PLB Advance pointers in pfCopyMemory() and pfSetMemory()\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-#ifdef PF_NO_CLIB\r
-/* Count chars until NUL.  Replace strlen() */\r
-#define  NUL  ((char) 0)\r
-cell_t pfCStringLength( const char *s )\r
-{\r
-       cell_t len = 0;\r
-       while( *s++ != NUL ) len++;\r
-       return len;\r
-}\r
- \r
-/*    void *memset (void *s, cell_t c, size_t n); */\r
-void *pfSetMemory( void *s, cell_t c, cell_t n )\r
-{\r
-       uint8_t *p = s, byt = (uint8_t) c;\r
-       while( (n--) > 0) *p++ = byt;\r
-       return s;\r
-}\r
-\r
-/*  void *memccpy (void *s1, const void *s2, cell_t c, size_t n); */\r
-void *pfCopyMemory( void *s1, const void *s2, cell_t n)\r
-{\r
-       uint8_t *p1 = s1;\r
-       const uint8_t *p2 = s2;\r
-       while( (n--) > 0) *p1++ = *p2++;\r
-       return s1;\r
-}\r
-\r
-#endif  /* PF_NO_CLIB */\r
-\r
-char pfCharToUpper( char c )\r
-{\r
-       return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c );\r
-}\r
-\r
-char pfCharToLower( char c )\r
-{\r
-       return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c );\r
-}\r
+/* @(#) pf_clib.c 96/12/18 1.12 */
+/***************************************************************
+** Duplicate functions from stdlib for PForth based on 'C'
+**
+** This code duplicates some of the code in the 'C' lib
+** because it reduces the dependency on foreign libraries
+** for monitor mode where no OS is available.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 961124 PLB Advance pointers in pfCopyMemory() and pfSetMemory()
+***************************************************************/
+
+#include "pf_all.h"
+
+#ifdef PF_NO_CLIB
+/* Count chars until NUL.  Replace strlen() */
+#define  NUL  ((char) 0)
+cell_t pfCStringLength( const char *s )
+{
+    cell_t len = 0;
+    while( *s++ != NUL ) len++;
+    return len;
+}
+
+/*    void *memset (void *s, cell_t c, size_t n); */
+void *pfSetMemory( void *s, cell_t c, cell_t n )
+{
+    uint8_t *p = s, byt = (uint8_t) c;
+    while( (n--) > 0) *p++ = byt;
+    return s;
+}
+
+/*  void *memccpy (void *s1, const void *s2, cell_t c, size_t n); */
+void *pfCopyMemory( void *s1, const void *s2, cell_t n)
+{
+    uint8_t *p1 = s1;
+    const uint8_t *p2 = s2;
+    while( (n--) > 0) *p1++ = *p2++;
+    return s1;
+}
+
+#endif  /* PF_NO_CLIB */
+
+char pfCharToUpper( char c )
+{
+    return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c );
+}
+
+char pfCharToLower( char c )
+{
+    return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c );
+}

diff --git a/csrc/pf_clib.h b/csrc/pf_clib.h
index da3dc5f..5cb5007 100644 (file)
--- a/csrc/pf_clib.h
+++ b/csrc/pf_clib.h
@@ -1,63 +1,63 @@
-/* @(#) pf_clib.h 96/12/18 1.10 */\r
-#ifndef _pf_clib_h\r
-#define _pf_clib_h\r
-\r
-/***************************************************************\r
-** Include file for PForth tools\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#ifdef  PF_NO_CLIB\r
-\r
-       #ifdef __cplusplus\r
-       extern "C" {\r
-       #endif\r
-\r
-       cell_t pfCStringLength( const char *s );\r
-       void *pfSetMemory( void *s, cell_t c, cell_t n );\r
-       void *pfCopyMemory( void *s1, const void *s2, cell_t n);\r
-       #define EXIT(n)  {while(1);}\r
-       \r
-       #ifdef __cplusplus\r
-       }   \r
-       #endif\r
-\r
-#else   /* PF_NO_CLIB */\r
-\r
-       #ifdef PF_USER_CLIB\r
-               #include PF_USER_CLIB\r
-       #else\r
-/* Use stdlib functions if available because they are probably faster. */\r
-               #define pfCStringLength strlen\r
-               #define pfSetMemory     memset\r
-               #define pfCopyMemory    memcpy\r
-               #define EXIT(n)  exit(n)\r
-       #endif /* PF_USER_CLIB */\r
-       \r
-#endif  /* !PF_NO_CLIB */\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */\r
-char pfCharToUpper( char c );\r
-char pfCharToLower( char c );\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pf_clib_h */\r
+/* @(#) pf_clib.h 96/12/18 1.10 */
+#ifndef _pf_clib_h
+#define _pf_clib_h
+
+/***************************************************************
+** Include file for PForth tools
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#ifdef  PF_NO_CLIB
+
+    #ifdef __cplusplus
+    extern "C" {
+    #endif
+
+    cell_t pfCStringLength( const char *s );
+    void *pfSetMemory( void *s, cell_t c, cell_t n );
+    void *pfCopyMemory( void *s1, const void *s2, cell_t n);
+    #define EXIT(n)  {while(1);}
+
+    #ifdef __cplusplus
+    }
+    #endif
+
+#else   /* PF_NO_CLIB */
+
+    #ifdef PF_USER_CLIB
+        #include PF_USER_CLIB
+    #else
+/* Use stdlib functions if available because they are probably faster. */
+        #define pfCStringLength strlen
+        #define pfSetMemory     memset
+        #define pfCopyMemory    memcpy
+        #define EXIT(n)  exit(n)
+    #endif /* PF_USER_CLIB */
+
+#endif  /* !PF_NO_CLIB */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */
+char pfCharToUpper( char c );
+char pfCharToLower( char c );
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pf_clib_h */

diff --git a/csrc/pf_core.c b/csrc/pf_core.c
index 00149f4..1736aa9 100644 (file)
--- a/csrc/pf_core.c
+++ b/csrc/pf_core.c
@@ -1,590 +1,590 @@
-/* @(#) pf_core.c 98/01/28 1.5 */\r
-/***************************************************************\r
-** Forth based on 'C'\r
-**\r
-** This file has the main entry points to the pForth library.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 940502 PLB Creation.\r
-** 940505 PLB More macros.\r
-** 940509 PLB Moved all stack handling into inner interpreter.\r
-**        Added Create, Colon, Semicolon, HNumberQ, etc.\r
-** 940510 PLB Got inner interpreter working with secondaries.\r
-**        Added (LITERAL).   Compiles colon definitions.\r
-** 940511 PLB Added conditionals, LITERAL, CREATE DOES>\r
-** 940512 PLB Added DO LOOP DEFER, fixed R>\r
-** 940520 PLB Added INCLUDE\r
-** 940521 PLB Added NUMBER?\r
-** 940930 PLB Outer Interpreter now uses deferred NUMBER?\r
-** 941005 PLB Added ANSI locals, LEAVE, modularised\r
-** 950320 RDG Added underflow checking for FP stack\r
-** 970702 PLB Added STACK_SAFETY to FP stack size.\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
- \r
-/***************************************************************\r
-** Global Data\r
-***************************************************************/\r
-\r
-char          gScratch[TIB_SIZE];\r
-pfTaskData_t   *gCurrentTask = NULL;\r
-pfDictionary_t *gCurrentDictionary;\r
-cell_t         gNumPrimitives;\r
-\r
-ExecToken     gLocalCompiler_XT;   /* custom compiler for local variables */\r
-ExecToken     gNumberQ_XT;         /* XT of NUMBER? */\r
-ExecToken     gQuitP_XT;           /* XT of (QUIT) */\r
-ExecToken     gAcceptP_XT;         /* XT of ACCEPT */\r
-\r
-/* Depth of data stack when colon called. */\r
-cell_t         gDepthAtColon;\r
-\r
-/* Global Forth variables. */\r
-cell_t          gVarContext;      /* Points to last name field. */\r
-cell_t          gVarState;        /* 1 if compiling. */\r
-cell_t          gVarBase;         /* Numeric Base. */\r
-cell_t          gVarEcho;              /* Echo input. */\r
-cell_t          gVarTraceLevel;   /* Trace Level for Inner Interpreter. */\r
-cell_t          gVarTraceStack;   /* Dump Stack each time if true. */\r
-cell_t          gVarTraceFlags;   /* Enable various internal debug messages. */\r
-cell_t          gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */\r
-cell_t          gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */\r
-\r
-/* data for INCLUDE that allows multiple nested files. */\r
-IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];\r
-cell_t         gIncludeIndex;\r
-\r
-static void pfResetForthTask( void );\r
-static void pfInit( void );\r
-static void pfTerm( void );\r
-\r
-/* TODO move to pf_config.h header. */\r
-#define DEFAULT_RETURN_DEPTH (512)\r
-#define DEFAULT_USER_DEPTH (512)\r
-#define DEFAULT_HEADER_SIZE (120000)\r
-#define DEFAULT_CODE_SIZE (300000)\r
-\r
-/* Initialize globals in a function to simplify loading on\r
- * embedded systems which may not support initialization of data section.\r
- */\r
-static void pfInit( void )\r
-{\r
-/* all zero */\r
-       gCurrentTask = NULL;\r
-       gCurrentDictionary = NULL;\r
-       gNumPrimitives = 0;\r
-       gLocalCompiler_XT = 0;\r
-       gVarContext = (cell_t)NULL;   /* Points to last name field. */\r
-       gVarState = 0;        /* 1 if compiling. */\r
-       gVarEcho = 0;       /* Echo input. */\r
-       gVarTraceLevel = 0;   /* Trace Level for Inner Interpreter. */\r
-       gVarTraceFlags = 0;   /* Enable various internal debug messages. */\r
-       gVarReturnCode = 0;   /* Returned to caller of Forth, eg. UNIX shell. */\r
-       gIncludeIndex = 0;\r
-       \r
-/* non-zero */\r
-       gVarBase = 10;        /* Numeric Base. */\r
-       gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
-       gVarTraceStack = 1;\r
-       \r
-       pfInitMemoryAllocator();\r
-       ioInit();\r
-}\r
-static void pfTerm( void )\r
-{\r
-       ioTerm();\r
-}\r
-\r
-/***************************************************************\r
-** Task Management\r
-***************************************************************/\r
-\r
-void pfDeleteTask( PForthTask task )\r
-{\r
-       pfTaskData_t *cftd = (pfTaskData_t *)task;\r
-       FREE_VAR( cftd->td_ReturnLimit );\r
-       FREE_VAR( cftd->td_StackLimit );\r
-       pfFreeMem( cftd );\r
-}\r
-\r
-/* Allocate some extra cells to protect against mild stack underflows. */\r
-#define STACK_SAFETY  (8)\r
-PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )\r
-{\r
-       pfTaskData_t *cftd;\r
-\r
-       cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );\r
-       if( !cftd ) goto nomem;\r
-       pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));\r
-\r
-/* Allocate User Stack */\r
-       cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *\r
-                               (UserStackDepth + STACK_SAFETY)));\r
-       if( !cftd->td_StackLimit ) goto nomem;\r
-       cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;\r
-       cftd->td_StackPtr = cftd->td_StackBase;\r
-\r
-/* Allocate Return Stack */\r
-       cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );\r
-       if( !cftd->td_ReturnLimit ) goto nomem;\r
-       cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;\r
-       cftd->td_ReturnPtr = cftd->td_ReturnBase;\r
-\r
-/* Allocate Float Stack */\r
-#ifdef PF_SUPPORT_FP\r
-/* Allocate room for as many Floats as we do regular data. */\r
-       cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *\r
-                               (UserStackDepth + STACK_SAFETY)));\r
-       if( !cftd->td_FloatStackLimit ) goto nomem;\r
-       cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;\r
-       cftd->td_FloatStackPtr = cftd->td_FloatStackBase;\r
-#endif\r
-\r
-       cftd->td_InputStream = PF_STDIN;\r
-\r
-       cftd->td_SourcePtr = &cftd->td_TIB[0];\r
-       cftd->td_SourceNum = 0;\r
-       \r
-       return (PForthTask) cftd;\r
-\r
-nomem:\r
-       ERR("CreateTaskContext: insufficient memory.\n");\r
-       if( cftd ) pfDeleteTask( (PForthTask) cftd );\r
-       return NULL;\r
-}\r
-\r
-/***************************************************************\r
-** Dictionary Management\r
-***************************************************************/\r
-\r
-cell_t pfExecIfDefined( const char *CString )\r
-{\r
-       int result = 0;\r
-       if( NAME_BASE != (cell_t)NULL)\r
-       {\r
-               ExecToken  XT;\r
-               if( ffFindC( CString, &XT ) )\r
-               {\r
-                       result = pfCatch( XT );\r
-               }\r
-       }\r
-       return result;\r
-}\r
-\r
-/***************************************************************\r
-** Delete a dictionary created by pfCreateDictionary()\r
-*/\r
-void pfDeleteDictionary( PForthDictionary dictionary )\r
-{\r
-       pfDictionary_t *dic = (pfDictionary_t *) dictionary;\r
-       if( !dic ) return;\r
-       \r
-       if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )\r
-       {\r
-               FREE_VAR( dic->dic_HeaderBaseUnaligned );\r
-               FREE_VAR( dic->dic_CodeBaseUnaligned );\r
-       }\r
-       pfFreeMem( dic );\r
-}\r
-\r
-/***************************************************************\r
-** Create a complete dictionary.\r
-** The dictionary consists of two parts, the header with the names,\r
-** and the code portion.\r
-** Delete using pfDeleteDictionary().\r
-** Return pointer to dictionary management structure.\r
-*/\r
-PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )\r
-{\r
-/* Allocate memory for initial dictionary. */\r
-       pfDictionary_t *dic;\r
-\r
-       dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );\r
-       if( !dic ) goto nomem;\r
-       pfSetMemory( dic, 0, sizeof( pfDictionary_t ));\r
-\r
-       dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;\r
-\r
-/* Align dictionary segments to preserve alignment of floats across hosts.\r
- * Thank you Helmut Proelss for pointing out that this needs to be cast\r
- * to (ucell_t) on 16 bit systems.\r
- */\r
-#define DIC_ALIGNMENT_SIZE  ((ucell_t)(0x10))\r
-#define DIC_ALIGN(addr)  ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))\r
-\r
-/* Allocate memory for header. */\r
-       if( HeaderSize > 0 )\r
-       {\r
-               dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );\r
-               if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
-/* Align header base. */\r
-               dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);\r
-               pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);\r
-               dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;\r
-               dic->dic_HeaderPtr = dic->dic_HeaderBase;\r
-       }\r
-       else\r
-       {\r
-               dic->dic_HeaderBase = 0;\r
-       }\r
-\r
-/* Allocate memory for code. */\r
-       dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );\r
-       if( !dic->dic_CodeBaseUnaligned ) goto nomem;\r
-       dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);\r
-       pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);\r
-\r
-       dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;\r
-       dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES))); \r
-       \r
-       return (PForthDictionary) dic;\r
-nomem:\r
-       pfDeleteDictionary( dic );\r
-       return NULL;\r
-}\r
-\r
-/***************************************************************\r
-** Used by Quit and other routines to restore system.\r
-***************************************************************/\r
-\r
-static void pfResetForthTask( void )\r
-{\r
-/* Go back to terminal input. */\r
-       gCurrentTask->td_InputStream = PF_STDIN;\r
-       \r
-/* Reset stacks. */\r
-       gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;\r
-       gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;\r
-#ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */\r
-       gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;\r
-#endif\r
-\r
-/* Advance >IN to end of input. */\r
-       gCurrentTask->td_IN = gCurrentTask->td_SourceNum;\r
-       gVarState = 0;\r
-}\r
-\r
-/***************************************************************\r
-** Set current task context.\r
-***************************************************************/\r
-\r
-void pfSetCurrentTask( PForthTask task )\r
-{      \r
-       gCurrentTask = (pfTaskData_t *) task;\r
-}\r
-\r
-/***************************************************************\r
-** Set Quiet Flag.\r
-***************************************************************/\r
-\r
-void pfSetQuiet( cell_t IfQuiet )\r
-{      \r
-       gVarQuiet = (cell_t) IfQuiet;\r
-}\r
-\r
-/***************************************************************\r
-** Query message status.\r
-***************************************************************/\r
-\r
-cell_t  pfQueryQuiet( void )\r
-{      \r
-       return gVarQuiet;\r
-}\r
-\r
-/***************************************************************\r
-** Top level interpreter.\r
-***************************************************************/\r
-ThrowCode pfQuit( void )\r
-{\r
-       ThrowCode exception;\r
-       int go = 1;\r
-       \r
-       while(go)\r
-       {\r
-               exception = ffOuterInterpreterLoop();\r
-               if( exception == 0 )\r
-               {\r
-                       exception = ffOK();\r
-               }\r
-\r
-               switch( exception )\r
-               {\r
-               case 0:\r
-                       break;\r
-\r
-               case THROW_BYE:\r
-                       go = 0;\r
-                       break;\r
-\r
-               case THROW_ABORT:\r
-               default:\r
-                       ffDotS();\r
-                       pfReportThrow( exception );\r
-                       pfHandleIncludeError();\r
-                       pfResetForthTask();\r
-                       break;\r
-               }\r
-       }\r
-\r
-       return gVarReturnCode;\r
-}\r
-\r
-/***************************************************************\r
-** Include file based on 'C' name.\r
-***************************************************************/\r
-\r
-cell_t pfIncludeFile( const char *FileName )\r
-{\r
-       FileStream *fid;\r
-       cell_t Result;\r
-       char  buffer[32];\r
-       cell_t numChars, len;\r
-       \r
-/* Open file. */\r
-       fid = sdOpenFile( FileName, "r" );\r
-       if( fid == NULL )\r
-       {\r
-               ERR("pfIncludeFile could not open ");\r
-               ERR(FileName);\r
-               EMIT_CR;\r
-               return -1;\r
-       }\r
-       \r
-/* Create a dictionary word named ::::FileName for FILE? */\r
-       pfCopyMemory( &buffer[0], "::::", 4);\r
-       len = (cell_t) pfCStringLength(FileName);\r
-       numChars = ( len > (32-4-1) ) ? (32-4-1) : len;\r
-       pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );\r
-       CreateDicEntryC( ID_NOOP, buffer, 0 );\r
-       \r
-       Result = ffIncludeFile( fid ); /* Also close the file. */\r
-       \r
-/* Create a dictionary word named ;;;; for FILE? */\r
-       CreateDicEntryC( ID_NOOP, ";;;;", 0 );\r
-       \r
-       return Result;\r
-}\r
-\r
-/***************************************************************\r
-** Output 'C' string message.\r
-** Use sdTerminalOut which works before initializing gCurrentTask.\r
-***************************************************************/\r
-void pfDebugMessage( const char *CString )\r
-{\r
-#if 0\r
-       while( *CString )\r
-       {\r
-               char c = *CString++;\r
-               if( c == '\n' )\r
-               {\r
-                       sdTerminalOut( 0x0D );\r
-                       sdTerminalOut( 0x0A );\r
-                       pfDebugMessage( "DBG: " );\r
-               }\r
-               else\r
-               {\r
-                       sdTerminalOut( c );\r
-               }\r
-       }\r
-#else\r
-       (void)CString;\r
-#endif\r
-}\r
-\r
-/***************************************************************\r
-** Print a decimal number to debug output.\r
-*/\r
-void pfDebugPrintDecimalNumber( int n )\r
-{\r
-       pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );\r
-}\r
-\r
-\r
-/***************************************************************\r
-** Output 'C' string message.\r
-** This is provided to help avoid the use of printf() and other I/O\r
-** which may not be present on a small embedded system.\r
-** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.\r
-***************************************************************/\r
-void pfMessage( const char *CString )\r
-{\r
-       ioType( CString, (cell_t) pfCStringLength(CString) );\r
-}\r
-\r
-/**************************************************************************\r
-** Main entry point for pForth.\r
-*/\r
-cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )\r
-{\r
-       pfTaskData_t *cftd;\r
-       pfDictionary_t *dic = NULL;\r
-       cell_t Result = 0;\r
-       ExecToken  EntryPoint = 0;\r
-\r
-#ifdef PF_USER_INIT\r
-       Result = PF_USER_INIT;\r
-       if( Result < 0 ) goto error1;\r
-#endif\r
-\r
-       pfInit();\r
-       \r
-/* Allocate Task structure. */\r
-       pfDebugMessage("pfDoForth: call pfCreateTask()\n");\r
-       cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );\r
-\r
-       if( cftd )\r
-       {\r
-               pfSetCurrentTask( cftd );\r
-               \r
-               if( !gVarQuiet )\r
-               {\r
-                       MSG( "PForth V"PFORTH_VERSION );\r
-                       if( IsHostLittleEndian() ) MSG("-LE");\r
-                       else MSG("-BE");\r
-#if PF_BIG_ENDIAN_DIC\r
-            MSG("/BE");\r
-#elif PF_LITTLE_ENDIAN_DIC\r
-            MSG("/LE");\r
-#endif\r
-                       if (sizeof(cell_t) == 8)\r
-                       {\r
-                               MSG("/64");\r
-                       }\r
-                       else if (sizeof(cell_t) == 4)\r
-                       {\r
-                               MSG("/32");\r
-                       }\r
-                       \r
-                       MSG( ", built "__DATE__" "__TIME__ );\r
-               }\r
-\r
-/* Don't use MSG before task set. */\r
-               if( SourceName )\r
-               {\r
-                       pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");\r
-               }\r
-\r
-\r
-#ifdef PF_NO_GLOBAL_INIT\r
-               if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */\r
-#endif\r
-\r
-#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
-               if( IfInit )\r
-               {\r
-                       pfDebugMessage("Build dictionary from scratch.\n");\r
-                       dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );\r
-               }\r
-               else\r
-#else\r
-               TOUCH(IfInit);\r
-#endif /* !PF_NO_INIT && !PF_NO_SHELL*/\r
-               {\r
-                       if( DicFileName )\r
-                       {\r
-                               pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");\r
-                               if( !gVarQuiet )\r
-                               {\r
-                                       EMIT_CR;\r
-                               }\r
-                               dic = pfLoadDictionary( DicFileName, &EntryPoint );\r
-                       }\r
-                       else\r
-                       {\r
-                               if( !gVarQuiet )\r
-                               {\r
-                                       MSG(" (static)");\r
-                                       EMIT_CR;\r
-                               }\r
-                               dic = pfLoadStaticDictionary();                 \r
-                       }\r
-               }\r
-               if( dic == NULL ) goto error2;\r
-               \r
-               if( !gVarQuiet )\r
-               {\r
-                       EMIT_CR;\r
-               }\r
-               \r
-               pfDebugMessage("pfDoForth: try AUTO.INIT\n");\r
-               Result = pfExecIfDefined("AUTO.INIT");\r
-               if( Result != 0 )\r
-               {\r
-                       MSG("Error in AUTO.INIT");\r
-                       goto error2;\r
-               }\r
- \r
-               if( EntryPoint != 0 )\r
-               {\r
-                       Result = pfCatch( EntryPoint );\r
-               }\r
-#ifndef PF_NO_SHELL\r
-               else\r
-               {\r
-                       if( SourceName == NULL )\r
-                       {\r
-                               pfDebugMessage("pfDoForth: pfQuit\n");\r
-                               Result = pfQuit();\r
-                       }\r
-                       else\r
-                       {\r
-                               if( !gVarQuiet )\r
-                               {\r
-                                       MSG("Including: ");\r
-                                       MSG(SourceName);\r
-                                       MSG("\n");\r
-                               }\r
-                               Result = pfIncludeFile( SourceName );\r
-                       }\r
-               }\r
-#endif /* PF_NO_SHELL */\r
-\r
-       /* Clean up after running Forth. */\r
-               pfExecIfDefined("AUTO.TERM");\r
-               pfDeleteDictionary( dic );\r
-               pfDeleteTask( cftd );\r
-       }\r
-               \r
-       pfTerm();\r
-\r
-#ifdef PF_USER_TERM\r
-       PF_USER_TERM;\r
-#endif\r
-       \r
-       return Result;\r
-       \r
-error2:\r
-       MSG("pfDoForth: Error occured.\n");\r
-       pfDeleteTask( cftd );\r
-       /* Terminate so we restore normal shell tty mode. */\r
-       pfTerm();\r
-\r
-#ifdef PF_USER_INIT\r
-error1:\r
-#endif\r
-\r
-       return -1;\r
-}\r
-\r
-\r
-#ifdef PF_UNIT_TEST\r
-cell_t pfUnitTest( void )\r
-{\r
-       cell_t numErrors = 0;\r
-       numErrors += pfUnitTestText();\r
-       return numErrors;\r
-}\r
-#endif\r
+/* @(#) pf_core.c 98/01/28 1.5 */
+/***************************************************************
+** Forth based on 'C'
+**
+** This file has the main entry points to the pForth library.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 940502 PLB Creation.
+** 940505 PLB More macros.
+** 940509 PLB Moved all stack handling into inner interpreter.
+**        Added Create, Colon, Semicolon, HNumberQ, etc.
+** 940510 PLB Got inner interpreter working with secondaries.
+**        Added (LITERAL).   Compiles colon definitions.
+** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
+** 940512 PLB Added DO LOOP DEFER, fixed R>
+** 940520 PLB Added INCLUDE
+** 940521 PLB Added NUMBER?
+** 940930 PLB Outer Interpreter now uses deferred NUMBER?
+** 941005 PLB Added ANSI locals, LEAVE, modularised
+** 950320 RDG Added underflow checking for FP stack
+** 970702 PLB Added STACK_SAFETY to FP stack size.
+***************************************************************/
+
+#include "pf_all.h"
+
+/***************************************************************
+** Global Data
+***************************************************************/
+
+char          gScratch[TIB_SIZE];
+pfTaskData_t   *gCurrentTask = NULL;
+pfDictionary_t *gCurrentDictionary;
+cell_t         gNumPrimitives;
+
+ExecToken     gLocalCompiler_XT;   /* custom compiler for local variables */
+ExecToken     gNumberQ_XT;         /* XT of NUMBER? */
+ExecToken     gQuitP_XT;           /* XT of (QUIT) */
+ExecToken     gAcceptP_XT;         /* XT of ACCEPT */
+
+/* Depth of data stack when colon called. */
+cell_t         gDepthAtColon;
+
+/* Global Forth variables. */
+cell_t          gVarContext;      /* Points to last name field. */
+cell_t          gVarState;        /* 1 if compiling. */
+cell_t          gVarBase;         /* Numeric Base. */
+cell_t          gVarEcho;           /* Echo input. */
+cell_t          gVarTraceLevel;   /* Trace Level for Inner Interpreter. */
+cell_t          gVarTraceStack;   /* Dump Stack each time if true. */
+cell_t          gVarTraceFlags;   /* Enable various internal debug messages. */
+cell_t          gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */
+cell_t          gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */
+
+/* data for INCLUDE that allows multiple nested files. */
+IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];
+cell_t         gIncludeIndex;
+
+static void pfResetForthTask( void );
+static void pfInit( void );
+static void pfTerm( void );
+
+/* TODO move to pf_config.h header. */
+#define DEFAULT_RETURN_DEPTH (512)
+#define DEFAULT_USER_DEPTH (512)
+#define DEFAULT_HEADER_SIZE (120000)
+#define DEFAULT_CODE_SIZE (300000)
+
+/* Initialize globals in a function to simplify loading on
+ * embedded systems which may not support initialization of data section.
+ */
+static void pfInit( void )
+{
+/* all zero */
+    gCurrentTask = NULL;
+    gCurrentDictionary = NULL;
+    gNumPrimitives = 0;
+    gLocalCompiler_XT = 0;
+    gVarContext = (cell_t)NULL;   /* Points to last name field. */
+    gVarState = 0;        /* 1 if compiling. */
+    gVarEcho = 0;       /* Echo input. */
+    gVarTraceLevel = 0;   /* Trace Level for Inner Interpreter. */
+    gVarTraceFlags = 0;   /* Enable various internal debug messages. */
+    gVarReturnCode = 0;   /* Returned to caller of Forth, eg. UNIX shell. */
+    gIncludeIndex = 0;
+
+/* non-zero */
+    gVarBase = 10;        /* Numeric Base. */
+    gDepthAtColon = DEPTH_AT_COLON_INVALID;
+    gVarTraceStack = 1;
+
+    pfInitMemoryAllocator();
+    ioInit();
+}
+static void pfTerm( void )
+{
+    ioTerm();
+}
+
+/***************************************************************
+** Task Management
+***************************************************************/
+
+void pfDeleteTask( PForthTask task )
+{
+    pfTaskData_t *cftd = (pfTaskData_t *)task;
+    FREE_VAR( cftd->td_ReturnLimit );
+    FREE_VAR( cftd->td_StackLimit );
+    pfFreeMem( cftd );
+}
+
+/* Allocate some extra cells to protect against mild stack underflows. */
+#define STACK_SAFETY  (8)
+PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
+{
+    pfTaskData_t *cftd;
+
+    cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
+    if( !cftd ) goto nomem;
+    pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
+
+/* Allocate User Stack */
+    cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
+                (UserStackDepth + STACK_SAFETY)));
+    if( !cftd->td_StackLimit ) goto nomem;
+    cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
+    cftd->td_StackPtr = cftd->td_StackBase;
+
+/* Allocate Return Stack */
+    cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
+    if( !cftd->td_ReturnLimit ) goto nomem;
+    cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
+    cftd->td_ReturnPtr = cftd->td_ReturnBase;
+
+/* Allocate Float Stack */
+#ifdef PF_SUPPORT_FP
+/* Allocate room for as many Floats as we do regular data. */
+    cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
+                (UserStackDepth + STACK_SAFETY)));
+    if( !cftd->td_FloatStackLimit ) goto nomem;
+    cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
+    cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
+#endif
+
+    cftd->td_InputStream = PF_STDIN;
+
+    cftd->td_SourcePtr = &cftd->td_TIB[0];
+    cftd->td_SourceNum = 0;
+
+    return (PForthTask) cftd;
+
+nomem:
+    ERR("CreateTaskContext: insufficient memory.\n");
+    if( cftd ) pfDeleteTask( (PForthTask) cftd );
+    return NULL;
+}
+
+/***************************************************************
+** Dictionary Management
+***************************************************************/
+
+cell_t pfExecIfDefined( const char *CString )
+{
+    int result = 0;
+    if( NAME_BASE != (cell_t)NULL)
+    {
+        ExecToken  XT;
+        if( ffFindC( CString, &XT ) )
+        {
+            result = pfCatch( XT );
+        }
+    }
+    return result;
+}
+
+/***************************************************************
+** Delete a dictionary created by pfCreateDictionary()
+*/
+void pfDeleteDictionary( PForthDictionary dictionary )
+{
+    pfDictionary_t *dic = (pfDictionary_t *) dictionary;
+    if( !dic ) return;
+
+    if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
+    {
+        FREE_VAR( dic->dic_HeaderBaseUnaligned );
+        FREE_VAR( dic->dic_CodeBaseUnaligned );
+    }
+    pfFreeMem( dic );
+}
+
+/***************************************************************
+** Create a complete dictionary.
+** The dictionary consists of two parts, the header with the names,
+** and the code portion.
+** Delete using pfDeleteDictionary().
+** Return pointer to dictionary management structure.
+*/
+PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
+{
+/* Allocate memory for initial dictionary. */
+    pfDictionary_t *dic;
+
+    dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
+    if( !dic ) goto nomem;
+    pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
+
+    dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
+
+/* Align dictionary segments to preserve alignment of floats across hosts.
+ * Thank you Helmut Proelss for pointing out that this needs to be cast
+ * to (ucell_t) on 16 bit systems.
+ */
+#define DIC_ALIGNMENT_SIZE  ((ucell_t)(0x10))
+#define DIC_ALIGN(addr)  ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
+
+/* Allocate memory for header. */
+    if( HeaderSize > 0 )
+    {
+        dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
+        if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
+/* Align header base. */
+        dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
+        pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
+        dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
+        dic->dic_HeaderPtr = dic->dic_HeaderBase;
+    }
+    else
+    {
+        dic->dic_HeaderBase = 0;
+    }
+
+/* Allocate memory for code. */
+    dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
+    if( !dic->dic_CodeBaseUnaligned ) goto nomem;
+    dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
+    pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
+
+    dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
+    dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
+
+    return (PForthDictionary) dic;
+nomem:
+    pfDeleteDictionary( dic );
+    return NULL;
+}
+
+/***************************************************************
+** Used by Quit and other routines to restore system.
+***************************************************************/
+
+static void pfResetForthTask( void )
+{
+/* Go back to terminal input. */
+    gCurrentTask->td_InputStream = PF_STDIN;
+
+/* Reset stacks. */
+    gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
+    gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
+#ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */
+    gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
+#endif
+
+/* Advance >IN to end of input. */
+    gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
+    gVarState = 0;
+}
+
+/***************************************************************
+** Set current task context.
+***************************************************************/
+
+void pfSetCurrentTask( PForthTask task )
+{
+    gCurrentTask = (pfTaskData_t *) task;
+}
+
+/***************************************************************
+** Set Quiet Flag.
+***************************************************************/
+
+void pfSetQuiet( cell_t IfQuiet )
+{
+    gVarQuiet = (cell_t) IfQuiet;
+}
+
+/***************************************************************
+** Query message status.
+***************************************************************/
+
+cell_t  pfQueryQuiet( void )
+{
+    return gVarQuiet;
+}
+
+/***************************************************************
+** Top level interpreter.
+***************************************************************/
+ThrowCode pfQuit( void )
+{
+    ThrowCode exception;
+    int go = 1;
+
+    while(go)
+    {
+        exception = ffOuterInterpreterLoop();
+        if( exception == 0 )
+        {
+            exception = ffOK();
+        }
+
+        switch( exception )
+        {
+        case 0:
+            break;
+
+        case THROW_BYE:
+            go = 0;
+            break;
+
+        case THROW_ABORT:
+        default:
+            ffDotS();
+            pfReportThrow( exception );
+            pfHandleIncludeError();
+            pfResetForthTask();
+            break;
+        }
+    }
+
+    return gVarReturnCode;
+}
+
+/***************************************************************
+** Include file based on 'C' name.
+***************************************************************/
+
+cell_t pfIncludeFile( const char *FileName )
+{
+    FileStream *fid;
+    cell_t Result;
+    char  buffer[32];
+    cell_t numChars, len;
+
+/* Open file. */
+    fid = sdOpenFile( FileName, "r" );
+    if( fid == NULL )
+    {
+        ERR("pfIncludeFile could not open ");
+        ERR(FileName);
+        EMIT_CR;
+        return -1;
+    }
+
+/* Create a dictionary word named ::::FileName for FILE? */
+    pfCopyMemory( &buffer[0], "::::", 4);
+    len = (cell_t) pfCStringLength(FileName);
+    numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
+    pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
+    CreateDicEntryC( ID_NOOP, buffer, 0 );
+
+    Result = ffIncludeFile( fid ); /* Also close the file. */
+
+/* Create a dictionary word named ;;;; for FILE? */
+    CreateDicEntryC( ID_NOOP, ";;;;", 0 );
+
+    return Result;
+}
+
+/***************************************************************
+** Output 'C' string message.
+** Use sdTerminalOut which works before initializing gCurrentTask.
+***************************************************************/
+void pfDebugMessage( const char *CString )
+{
+#if 0
+    while( *CString )
+    {
+        char c = *CString++;
+        if( c == '\n' )
+        {
+            sdTerminalOut( 0x0D );
+            sdTerminalOut( 0x0A );
+            pfDebugMessage( "DBG: " );
+        }
+        else
+        {
+            sdTerminalOut( c );
+        }
+    }
+#else
+    (void)CString;
+#endif
+}
+
+/***************************************************************
+** Print a decimal number to debug output.
+*/
+void pfDebugPrintDecimalNumber( int n )
+{
+    pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
+}
+
+
+/***************************************************************
+** Output 'C' string message.
+** This is provided to help avoid the use of printf() and other I/O
+** which may not be present on a small embedded system.
+** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
+***************************************************************/
+void pfMessage( const char *CString )
+{
+    ioType( CString, (cell_t) pfCStringLength(CString) );
+}
+
+/**************************************************************************
+** Main entry point for pForth.
+*/
+cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
+{
+    pfTaskData_t *cftd;
+    pfDictionary_t *dic = NULL;
+    cell_t Result = 0;
+    ExecToken  EntryPoint = 0;
+
+#ifdef PF_USER_INIT
+    Result = PF_USER_INIT;
+    if( Result < 0 ) goto error1;
+#endif
+
+    pfInit();
+
+/* Allocate Task structure. */
+    pfDebugMessage("pfDoForth: call pfCreateTask()\n");
+    cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
+
+    if( cftd )
+    {
+        pfSetCurrentTask( cftd );
+
+        if( !gVarQuiet )
+        {
+            MSG( "PForth V"PFORTH_VERSION );
+            if( IsHostLittleEndian() ) MSG("-LE");
+            else MSG("-BE");
+#if PF_BIG_ENDIAN_DIC
+            MSG("/BE");
+#elif PF_LITTLE_ENDIAN_DIC
+            MSG("/LE");
+#endif
+            if (sizeof(cell_t) == 8)
+            {
+                MSG("/64");
+            }
+            else if (sizeof(cell_t) == 4)
+            {
+                MSG("/32");
+            }
+
+            MSG( ", built "__DATE__" "__TIME__ );
+        }
+
+/* Don't use MSG before task set. */
+        if( SourceName )
+        {
+            pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
+        }
+
+
+#ifdef PF_NO_GLOBAL_INIT
+        if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
+#endif
+
+#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
+        if( IfInit )
+        {
+            pfDebugMessage("Build dictionary from scratch.\n");
+            dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
+        }
+        else
+#else
+        TOUCH(IfInit);
+#endif /* !PF_NO_INIT && !PF_NO_SHELL*/
+        {
+            if( DicFileName )
+            {
+                pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
+                if( !gVarQuiet )
+                {
+                    EMIT_CR;
+                }
+                dic = pfLoadDictionary( DicFileName, &EntryPoint );
+            }
+            else
+            {
+                if( !gVarQuiet )
+                {
+                    MSG(" (static)");
+                    EMIT_CR;
+                }
+                dic = pfLoadStaticDictionary();
+            }
+        }
+        if( dic == NULL ) goto error2;
+
+        if( !gVarQuiet )
+        {
+            EMIT_CR;
+        }
+
+        pfDebugMessage("pfDoForth: try AUTO.INIT\n");
+        Result = pfExecIfDefined("AUTO.INIT");
+        if( Result != 0 )
+        {
+            MSG("Error in AUTO.INIT");
+            goto error2;
+        }
+
+        if( EntryPoint != 0 )
+        {
+            Result = pfCatch( EntryPoint );
+        }
+#ifndef PF_NO_SHELL
+        else
+        {
+            if( SourceName == NULL )
+            {
+                pfDebugMessage("pfDoForth: pfQuit\n");
+                Result = pfQuit();
+            }
+            else
+            {
+                if( !gVarQuiet )
+                {
+                    MSG("Including: ");
+                    MSG(SourceName);
+                    MSG("\n");
+                }
+                Result = pfIncludeFile( SourceName );
+            }
+        }
+#endif /* PF_NO_SHELL */
+
+    /* Clean up after running Forth. */
+        pfExecIfDefined("AUTO.TERM");
+        pfDeleteDictionary( dic );
+        pfDeleteTask( cftd );
+    }
+
+    pfTerm();
+
+#ifdef PF_USER_TERM
+    PF_USER_TERM;
+#endif
+
+    return Result;
+
+error2:
+    MSG("pfDoForth: Error occured.\n");
+    pfDeleteTask( cftd );
+    /* Terminate so we restore normal shell tty mode. */
+    pfTerm();
+
+#ifdef PF_USER_INIT
+error1:
+#endif
+
+    return -1;
+}
+
+
+#ifdef PF_UNIT_TEST
+cell_t pfUnitTest( void )
+{
+    cell_t numErrors = 0;
+    numErrors += pfUnitTestText();
+    return numErrors;
+}
+#endif

diff --git a/csrc/pf_core.h b/csrc/pf_core.h
index 1279e8b..ffae934 100644 (file)
--- a/csrc/pf_core.h
+++ b/csrc/pf_core.h
@@ -1,38 +1,38 @@
-/* @(#) pf_core.h 98/01/26 1.3 */\r
-#ifndef _pf_core_h\r
-#define _pf_core_h\r
-\r
-/***************************************************************\r
-** Include file for PForth 'C' Glue support\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-void   pfInitGlobals( void );\r
-\r
-void   pfDebugMessage( const char *CString );\r
-void   pfDebugPrintDecimalNumber( int n );\r
-       \r
-cell_t pfUnitTestText( void );\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-\r
-#endif /* _pf_core_h */\r
+/* @(#) pf_core.h 98/01/26 1.3 */
+#ifndef _pf_core_h
+#define _pf_core_h
+
+/***************************************************************
+** Include file for PForth 'C' Glue support
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void   pfInitGlobals( void );
+
+void   pfDebugMessage( const char *CString );
+void   pfDebugPrintDecimalNumber( int n );
+
+cell_t pfUnitTestText( void );
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* _pf_core_h */

diff --git a/csrc/pf_float.h b/csrc/pf_float.h
index bc7128e..1e4439e 100644 (file)
--- a/csrc/pf_float.h
+++ b/csrc/pf_float.h
@@ -1,43 +1,43 @@
-/* @(#) pf_float.h 98/01/28 1.1 */\r
-#ifndef _pf_float_h\r
-#define _pf_float_h\r
-\r
-/***************************************************************\r
-** Include file for PForth, a Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-typedef double PF_FLOAT;\r
-\r
-/* Define pForth specific math functions. */\r
-\r
-#define fp_acos   acos\r
-#define fp_asin   asin\r
-#define fp_atan   atan\r
-#define fp_atan2  atan2\r
-#define fp_cos    cos\r
-#define fp_cosh   cosh  \r
-#define fp_fabs   fabs\r
-#define fp_floor  floor\r
-#define fp_log    log  \r
-#define fp_log10  log10\r
-#define fp_pow    pow\r
-#define fp_sin    sin\r
-#define fp_sinh   sinh\r
-#define fp_sqrt   sqrt\r
-#define fp_tan    tan\r
-#define fp_tanh   tanh\r
-\r
-#endif\r
+/* @(#) pf_float.h 98/01/28 1.1 */
+#ifndef _pf_float_h
+#define _pf_float_h
+
+/***************************************************************
+** Include file for PForth, a Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+typedef double PF_FLOAT;
+
+/* Define pForth specific math functions. */
+
+#define fp_acos   acos
+#define fp_asin   asin
+#define fp_atan   atan
+#define fp_atan2  atan2
+#define fp_cos    cos
+#define fp_cosh   cosh
+#define fp_fabs   fabs
+#define fp_floor  floor
+#define fp_log    log
+#define fp_log10  log10
+#define fp_pow    pow
+#define fp_sin    sin
+#define fp_sinh   sinh
+#define fp_sqrt   sqrt
+#define fp_tan    tan
+#define fp_tanh   tanh
+
+#endif

diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h
index 80df530..3667824 100644 (file)
--- a/csrc/pf_guts.h
+++ b/csrc/pf_guts.h
@@ -1,597 +1,597 @@
-/* @(#) pf_guts.h 98/01/28 1.4 */\r
-#ifndef _pf_guts_h\r
-#define _pf_guts_h\r
-\r
-/***************************************************************\r
-** Include file for PForth, a Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-/*\r
-** PFORTH_VERSION changes when PForth is modified and released.\r
-** See README file for version info.\r
-*/\r
-#define PFORTH_VERSION "27"\r
-\r
-/*\r
-** PFORTH_FILE_VERSION changes when incompatible changes are made\r
-** in the ".dic" file format.\r
-**\r
-** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c".\r
-** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth().\r
-** FV5 - 950316 - Added Floats and reserved words.\r
-** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc.\r
-** FV7 - 971203 - Added ID_FILL, (1LOCAL@),  etc., ran out of reserved, resorted.\r
-** FV8 - 980818 - Added Endian flag.\r
-** FV9 - 20100503 - Added support for 64-bit CELL.\r
-*/\r
-#define PF_FILE_VERSION (9)   /* Bump this whenever primitives added. */\r
-#define PF_EARLIEST_FILE_VERSION (9)  /* earliest one still compatible */\r
-\r
-/***************************************************************\r
-** Sizes and other constants\r
-***************************************************************/\r
-\r
-#define TIB_SIZE (256)\r
-\r
-#ifndef FALSE\r
-       #define FALSE (0)\r
-#endif\r
-#ifndef TRUE\r
-       #define TRUE (1)\r
-#endif\r
-\r
-#define FFALSE (0)\r
-#define FTRUE (-1)\r
-#define BLANK (' ')\r
-\r
-#define FLAG_PRECEDENCE (0x80)\r
-#define FLAG_IMMEDIATE  (0x40)\r
-#define FLAG_SMUDGE     (0x20)\r
-#define MASK_NAME_SIZE  (0x1F)\r
-\r
-/* Debug TRACE flags */\r
-#define TRACE_INNER     (0x0002)\r
-#define TRACE_COMPILE   (0x0004)\r
-#define TRACE_SPECIAL   (0x0008)\r
-\r
-/* Numeric types returned by NUMBER? */\r
-#define NUM_TYPE_BAD    (0)\r
-#define NUM_TYPE_SINGLE (1)\r
-#define NUM_TYPE_DOUBLE (2)\r
-#define NUM_TYPE_FLOAT  (3)\r
-\r
-#define CREATE_BODY_OFFSET  (3*sizeof(cell_t))\r
-\r
-/***************************************************************\r
-** Primitive Token IDS\r
-** Do NOT change the order of these IDs or dictionary files will break!\r
-***************************************************************/\r
-enum cforth_primitive_ids\r
-{\r
-       ID_EXIT = 0,  /* ID_EXIT must always be zero. */\r
-/* Do NOT change the order of these IDs or dictionary files will break! */\r
-       ID_1MINUS,\r
-       ID_1PLUS,\r
-       ID_2DUP,\r
-       ID_2LITERAL,\r
-       ID_2LITERAL_P,\r
-       ID_2MINUS,\r
-       ID_2OVER,\r
-       ID_2PLUS,\r
-       ID_2SWAP,\r
-       ID_2_R_FETCH,\r
-       ID_2_R_FROM,\r
-       ID_2_TO_R,\r
-       ID_ACCEPT_P,\r
-       ID_ALITERAL,\r
-       ID_ALITERAL_P,\r
-       ID_ALLOCATE,\r
-       ID_AND,\r
-       ID_ARSHIFT,\r
-       ID_BAIL,\r
-       ID_BODY_OFFSET,\r
-       ID_BRANCH,\r
-       ID_BYE,\r
-       ID_CALL_C,\r
-       ID_CFETCH,\r
-       ID_CMOVE,\r
-       ID_CMOVE_UP,\r
-       ID_COLON,\r
-       ID_COLON_P,\r
-       ID_COMPARE,\r
-       ID_COMP_EQUAL,\r
-       ID_COMP_GREATERTHAN,\r
-       ID_COMP_LESSTHAN,\r
-       ID_COMP_NOT_EQUAL,\r
-       ID_COMP_U_GREATERTHAN,\r
-       ID_COMP_U_LESSTHAN,\r
-       ID_COMP_ZERO_EQUAL,\r
-       ID_COMP_ZERO_GREATERTHAN,\r
-       ID_COMP_ZERO_LESSTHAN,\r
-       ID_COMP_ZERO_NOT_EQUAL,\r
-       ID_CR,\r
-       ID_CREATE,\r
-       ID_CREATE_P,\r
-       ID_CSTORE,\r
-       ID_DEFER,\r
-       ID_DEFER_P,\r
-       ID_DEPTH,\r
-       ID_DIVIDE,\r
-       ID_DOT,\r
-       ID_DOTS,\r
-       ID_DO_P,\r
-       ID_DROP,\r
-       ID_DUMP,\r
-       ID_DUP,\r
-       ID_D_MINUS,\r
-       ID_D_MTIMES,\r
-       ID_D_MUSMOD,\r
-       ID_D_PLUS,\r
-       ID_D_UMSMOD,\r
-       ID_D_UMTIMES,\r
-       ID_EMIT,\r
-       ID_EMIT_P,\r
-       ID_EOL,\r
-       ID_ERRORQ_P,\r
-       ID_EXECUTE,\r
-       ID_FETCH,\r
-       ID_FILE_CLOSE,\r
-       ID_FILE_CREATE,\r
-       ID_FILE_OPEN,\r
-       ID_FILE_POSITION,\r
-       ID_FILE_READ,\r
-       ID_FILE_REPOSITION,\r
-       ID_FILE_RO,\r
-       ID_FILE_RW,\r
-       ID_FILE_SIZE,\r
-       ID_FILE_WRITE,\r
-       ID_FILL,\r
-       ID_FIND,\r
-       ID_FINDNFA,\r
-       ID_FLUSHEMIT,\r
-       ID_FREE,\r
-       ID_HERE,\r
-       ID_NUMBERQ_P,\r
-       ID_I,\r
-       ID_INCLUDE_FILE,\r
-       ID_J,\r
-       ID_KEY,\r
-       ID_LEAVE_P,\r
-       ID_LITERAL,\r
-       ID_LITERAL_P,\r
-       ID_LOADSYS,\r
-       ID_LOCAL_COMPILER,\r
-       ID_LOCAL_ENTRY,\r
-       ID_LOCAL_EXIT,\r
-       ID_LOCAL_FETCH,\r
-       ID_LOCAL_FETCH_1,\r
-       ID_LOCAL_FETCH_2,\r
-       ID_LOCAL_FETCH_3,\r
-       ID_LOCAL_FETCH_4,\r
-       ID_LOCAL_FETCH_5,\r
-       ID_LOCAL_FETCH_6,\r
-       ID_LOCAL_FETCH_7,\r
-       ID_LOCAL_FETCH_8,\r
-       ID_LOCAL_PLUSSTORE,\r
-       ID_LOCAL_STORE,\r
-       ID_LOCAL_STORE_1,\r
-       ID_LOCAL_STORE_2,\r
-       ID_LOCAL_STORE_3,\r
-       ID_LOCAL_STORE_4,\r
-       ID_LOCAL_STORE_5,\r
-       ID_LOCAL_STORE_6,\r
-       ID_LOCAL_STORE_7,\r
-       ID_LOCAL_STORE_8,\r
-       ID_LOOP_P,\r
-       ID_LSHIFT,\r
-       ID_MAX,\r
-       ID_MIN,\r
-       ID_MINUS,\r
-       ID_NAME_TO_PREVIOUS,\r
-       ID_NAME_TO_TOKEN,\r
-       ID_NOOP,\r
-       ID_NUMBERQ,\r
-       ID_OR,\r
-       ID_OVER,\r
-       ID_PICK,\r
-       ID_PLUS,\r
-       ID_PLUSLOOP_P,\r
-       ID_PLUS_STORE,\r
-       ID_QDO_P,\r
-       ID_QDUP,\r
-       ID_QTERMINAL,\r
-       ID_QUIT_P,\r
-       ID_REFILL,\r
-       ID_RESIZE,\r
-       ID_RESTORE_INPUT,\r
-       ID_ROLL,\r
-       ID_ROT,\r
-       ID_RP_FETCH,\r
-       ID_RP_STORE,\r
-       ID_RSHIFT,\r
-       ID_R_DROP,\r
-       ID_R_FETCH,\r
-       ID_R_FROM,\r
-       ID_SAVE_FORTH_P,\r
-       ID_SAVE_INPUT,\r
-       ID_SCAN,\r
-       ID_SEMICOLON,\r
-       ID_SKIP,\r
-       ID_SOURCE,\r
-       ID_SOURCE_ID,\r
-       ID_SOURCE_ID_POP,\r
-       ID_SOURCE_ID_PUSH,\r
-       ID_SOURCE_SET,\r
-       ID_SP_FETCH,\r
-       ID_SP_STORE,\r
-       ID_STORE,\r
-       ID_SWAP,\r
-       ID_TEST1,\r
-       ID_TEST2,\r
-       ID_TEST3,\r
-       ID_TICK,\r
-       ID_TIMES,\r
-       ID_TO_R,\r
-       ID_TYPE,\r
-       ID_TYPE_P,\r
-       ID_VAR_BASE,\r
-       ID_VAR_CODE_BASE,\r
-       ID_VAR_CODE_LIMIT,\r
-       ID_VAR_CONTEXT,\r
-       ID_VAR_DP,\r
-       ID_VAR_ECHO,\r
-       ID_VAR_HEADERS_BASE,\r
-       ID_VAR_HEADERS_LIMIT,\r
-       ID_VAR_HEADERS_PTR,\r
-       ID_VAR_NUM_TIB,\r
-       ID_VAR_OUT,\r
-       ID_VAR_RETURN_CODE,\r
-       ID_VAR_SOURCE_ID,\r
-       ID_VAR_STATE,\r
-       ID_VAR_TO_IN,\r
-       ID_VAR_TRACE_FLAGS,\r
-       ID_VAR_TRACE_LEVEL,\r
-       ID_VAR_TRACE_STACK,\r
-       ID_VLIST,\r
-       ID_WORD,\r
-       ID_WORD_FETCH,\r
-       ID_WORD_STORE,\r
-       ID_XOR,\r
-       ID_ZERO_BRANCH,\r
-       ID_CATCH,\r
-       ID_THROW,\r
-       ID_INTERPRET,\r
-       ID_FILE_WO,\r
-       ID_FILE_BIN,\r
-       /* Added to support 64 bit operation. */\r
-       ID_CELL,\r
-       ID_CELLS,\r
-       /* DELETE-FILE */\r
-       ID_FILE_DELETE,\r
-/* If you add a word here, take away one reserved word below. */\r
-#ifdef PF_SUPPORT_FP\r
-/* Only reserve space if we are adding FP so that we can detect\r
-** unsupported primitives when loading dictionary.\r
-*/\r
-       ID_RESERVED01,\r
-       ID_RESERVED02,\r
-       ID_RESERVED03,\r
-       ID_RESERVED04,\r
-       ID_RESERVED05,\r
-       ID_RESERVED06,\r
-       ID_RESERVED07,\r
-       ID_RESERVED08,\r
-       ID_RESERVED09,\r
-       ID_RESERVED10,\r
-       ID_RESERVED11,\r
-       ID_RESERVED12,\r
-       ID_RESERVED13,\r
-       ID_FP_D_TO_F,\r
-       ID_FP_FSTORE,\r
-       ID_FP_FTIMES,\r
-       ID_FP_FPLUS,\r
-       ID_FP_FMINUS,\r
-       ID_FP_FSLASH,\r
-       ID_FP_F_ZERO_LESS_THAN,\r
-       ID_FP_F_ZERO_EQUALS,\r
-       ID_FP_F_LESS_THAN,\r
-       ID_FP_F_TO_D,\r
-       ID_FP_FFETCH,\r
-       ID_FP_FDEPTH,\r
-       ID_FP_FDROP,\r
-       ID_FP_FDUP,\r
-       ID_FP_FLITERAL,\r
-       ID_FP_FLITERAL_P,\r
-       ID_FP_FLOAT_PLUS,\r
-       ID_FP_FLOATS,\r
-       ID_FP_FLOOR,\r
-       ID_FP_FMAX,\r
-       ID_FP_FMIN,\r
-       ID_FP_FNEGATE,\r
-       ID_FP_FOVER,\r
-       ID_FP_FROT,\r
-       ID_FP_FROUND,\r
-       ID_FP_FSWAP,\r
-       ID_FP_FSTAR_STAR,\r
-       ID_FP_FABS,\r
-       ID_FP_FACOS,\r
-       ID_FP_FACOSH,\r
-       ID_FP_FALOG,\r
-       ID_FP_FASIN,\r
-       ID_FP_FASINH,\r
-       ID_FP_FATAN,\r
-       ID_FP_FATAN2,\r
-       ID_FP_FATANH,\r
-       ID_FP_FCOS,\r
-       ID_FP_FCOSH,\r
-       ID_FP_FLN,\r
-       ID_FP_FLNP1,\r
-       ID_FP_FLOG,\r
-       ID_FP_FSIN,\r
-       ID_FP_FSINCOS,\r
-       ID_FP_FSINH,\r
-       ID_FP_FSQRT,\r
-       ID_FP_FTAN,\r
-       ID_FP_FTANH,\r
-       ID_FP_FPICK,\r
-#endif\r
-/* Add new IDs by replacing reserved IDs or extending FP routines. */\r
-/* Do NOT change the order of these IDs or dictionary files will break! */\r
-       NUM_PRIMITIVES     /* This must always be LAST */\r
-};\r
-\r
-\r
-\r
-/***************************************************************\r
-** THROW Codes\r
-***************************************************************/\r
-/* ANSI standard definitions needed by pForth */\r
-#define THROW_ABORT            (-1)\r
-#define THROW_ABORT_QUOTE      (-2)\r
-#define THROW_STACK_OVERFLOW   (-3)\r
-#define THROW_STACK_UNDERFLOW  (-4)\r
-#define THROW_UNDEFINED_WORD  (-13)\r
-#define THROW_EXECUTING       (-14)\r
-#define THROW_PAIRS           (-22)\r
-#define THROW_FLOAT_STACK_UNDERFLOW  ( -45)\r
-#define THROW_QUIT            (-56)\r
-\r
-/* THROW codes unique to pForth */\r
-#define THROW_BYE            (-256) /* Exit program. */\r
-#define THROW_SEMICOLON      (-257) /* Error detected at ; */\r
-#define THROW_DEFERRED       (-258) /* Not a deferred word. Used in system.fth */\r
-\r
-/***************************************************************\r
-** Structures\r
-***************************************************************/\r
-\r
-typedef struct pfTaskData_s\r
-{\r
-       cell_t   *td_StackPtr;       /* Primary data stack */\r
-       cell_t   *td_StackBase;\r
-       cell_t   *td_StackLimit;\r
-       cell_t   *td_ReturnPtr;      /* Return stack */\r
-       cell_t   *td_ReturnBase;\r
-       cell_t   *td_ReturnLimit;\r
-#ifdef PF_SUPPORT_FP\r
-       PF_FLOAT  *td_FloatStackPtr;\r
-       PF_FLOAT  *td_FloatStackBase;\r
-       PF_FLOAT  *td_FloatStackLimit;\r
-#endif\r
-       cell_t   *td_InsPtr;          /* Instruction pointer, "PC" */\r
-       FileStream   *td_InputStream;\r
-/* Terminal. */\r
-       char    td_TIB[TIB_SIZE];   /* Buffer for terminal input. */\r
-       cell_t    td_IN;              /* Index into Source */\r
-       cell_t    td_SourceNum;       /* #TIB after REFILL */\r
-       char   *td_SourcePtr;       /* Pointer to TIB or other source. */\r
-       cell_t   td_LineNumber;      /* Incremented on every refill. */\r
-       cell_t    td_OUT;             /* Current output column. */\r
-} pfTaskData_t;\r
-\r
-typedef struct pfNode\r
-{\r
-       struct pfNode *n_Next;\r
-       struct pfNode *n_Prev;\r
-} pfNode;\r
-\r
-/* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/\r
-typedef struct cfNameLinks\r
-{\r
-       cell_t       cfnl_PreviousName;   /* name relative address of previous */\r
-       ExecToken  cfnl_ExecToken;      /* Execution token for word. */\r
-/* Followed by variable length name field. */\r
-} cfNameLinks;\r
-\r
-#define PF_DICF_ALLOCATED_SEGMENTS  ( 0x0001)\r
-typedef struct pfDictionary_s\r
-{\r
-       pfNode  dic_Node;\r
-       ucell_t  dic_Flags;\r
-/* Headers contain pointers to names and dictionary. */\r
-\r
-       ucell_t dic_HeaderBaseUnaligned;\r
-\r
-       ucell_t dic_HeaderBase;\r
-       ucell_t dic_HeaderPtr;\r
-       ucell_t dic_HeaderLimit;\r
-/* Code segment contains tokenized code and data. */\r
-       ucell_t dic_CodeBaseUnaligned;\r
-       ucell_t dic_CodeBase;\r
-       union\r
-       {\r
-               cell_t  *Cell;\r
-               uint8_t *Byte;\r
-       } dic_CodePtr;\r
-       ucell_t dic_CodeLimit;\r
-} pfDictionary_t;\r
-\r
-/* Save state of include when nesting files. */\r
-typedef struct IncludeFrame\r
-{\r
-       FileStream   *inf_FileID;\r
-       cell_t         inf_LineNumber;\r
-       cell_t         inf_SourceNum;\r
-       cell_t         inf_IN;\r
-       char          inf_SaveTIB[TIB_SIZE];\r
-} IncludeFrame;\r
-\r
-#define MAX_INCLUDE_DEPTH (16)\r
-\r
-/***************************************************************\r
-** Prototypes\r
-***************************************************************/\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-int pfCatch( ExecToken XT );\r
-\r
-#ifdef __cplusplus\r
-}\r
-#endif\r
-\r
-/***************************************************************\r
-** External Globals\r
-***************************************************************/\r
-extern pfTaskData_t *gCurrentTask;\r
-extern pfDictionary_t *gCurrentDictionary;\r
-extern char          gScratch[TIB_SIZE];\r
-extern cell_t         gNumPrimitives;\r
-\r
-extern ExecToken     gLocalCompiler_XT;      /* CFA of (LOCAL) compiler. */\r
-extern ExecToken     gNumberQ_XT;         /* XT of NUMBER? */\r
-extern ExecToken     gQuitP_XT;           /* XT of (QUIT) */\r
-extern ExecToken     gAcceptP_XT;         /* XT of ACCEPT */\r
-\r
-#define DEPTH_AT_COLON_INVALID (-100)\r
-extern cell_t         gDepthAtColon;\r
-\r
-/* Global variables. */\r
-extern cell_t        gVarContext;    /* Points to last name field. */\r
-extern cell_t        gVarState;      /* 1 if compiling. */\r
-extern cell_t        gVarBase;       /* Numeric Base. */\r
-extern cell_t        gVarEcho;       /* Echo input from file. */\r
-extern cell_t        gVarEchoAccept; /* Echo input from ACCEPT. */\r
-extern cell_t        gVarTraceLevel;\r
-extern cell_t        gVarTraceStack;\r
-extern cell_t        gVarTraceFlags;\r
-extern cell_t        gVarQuiet;             /* Suppress unnecessary messages, OK, etc. */\r
-extern cell_t        gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */\r
-\r
-extern IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];\r
-extern cell_t         gIncludeIndex;\r
-/***************************************************************\r
-** Macros\r
-***************************************************************/\r
-\r
-\r
-/* Endian specific macros for creating target dictionaries for machines with\r
-\r
-** different endian-ness.\r
-\r
-*/\r
-\r
-#if defined(PF_BIG_ENDIAN_DIC)\r
-\r
-#define WRITE_FLOAT_DIC             WriteFloatBigEndian\r
-#define WRITE_CELL_DIC(addr,data)   WriteCellBigEndian((uint8_t *)(addr),(ucell_t)(data))\r
-#define WRITE_SHORT_DIC(addr,data)  Write16BigEndian((uint8_t *)(addr),(uint16_t)(data))\r
-#define READ_FLOAT_DIC              ReadFloatBigEndian\r
-#define READ_CELL_DIC(addr)         ReadCellBigEndian((const uint8_t *)(addr))\r
-#define READ_SHORT_DIC(addr)        Read16BigEndian((const uint8_t *)(addr))\r
-\r
-#elif defined(PF_LITTLE_ENDIAN_DIC)\r
-\r
-#define WRITE_FLOAT_DIC             WriteFloatLittleEndian\r
-#define WRITE_CELL_DIC(addr,data)   WriteCellLittleEndian((uint8_t *)(addr),(ucell_t)(data))\r
-#define WRITE_SHORT_DIC(addr,data)  Write16LittleEndian((uint8_t *)(addr),(uint16_t)(data))\r
-#define READ_FLOAT_DIC              ReadFloatLittleEndian\r
-#define READ_CELL_DIC(addr)         ReadCellLittleEndian((const uint8_t *)(addr))\r
-#define READ_SHORT_DIC(addr)        Read16LittleEndian((const uint8_t *)(addr))\r
-\r
-#else\r
-\r
-#define WRITE_FLOAT_DIC(addr,data)  { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); }\r
-#define WRITE_CELL_DIC(addr,data)   { *((cell_t *)(addr)) = (cell_t)(data); }\r
-#define WRITE_SHORT_DIC(addr,data)  { *((int16_t *)(addr)) = (int16_t)(data); }\r
-#define READ_FLOAT_DIC(addr)        ( *((PF_FLOAT *)(addr)) )\r
-#define READ_CELL_DIC(addr)         ( *((const ucell_t *)(addr)) )\r
-#define READ_SHORT_DIC(addr)        ( *((const uint16_t *)(addr)) )\r
-\r
-#endif\r
-\r
-\r
-#define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell)\r
-#define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell)\r
-#define CODE_COMMA( N ) WRITE_CELL_DIC(CODE_HERE++,(N))\r
-#define NAME_BASE (gCurrentDictionary->dic_HeaderBase)\r
-#define CODE_BASE (gCurrentDictionary->dic_CodeBase)\r
-#define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase)\r
-#define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase)\r
-\r
-#define IN_CODE_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_CodeBase)   && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_CodeLimit) )\r
-\r
-#define IN_NAME_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_HeaderLimit) )\r
-#define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr))\r
-\r
-/* Address conversion */\r
-#define ABS_TO_NAMEREL( a ) ((cell_t)  (((ucell_t) a) - NAME_BASE ))\r
-#define ABS_TO_CODEREL( a ) ((cell_t)  (((ucell_t) a) - CODE_BASE ))\r
-#define NAMEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + NAME_BASE))\r
-#define CODEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + CODE_BASE))\r
-\r
-/* The check for >0 is only needed for CLONE testing. !!! */\r
-#define IsTokenPrimitive(xt) ((xt<gNumPrimitives) && (xt>=0))\r
-\r
-#define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } }\r
-\r
-#define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr)\r
-#define DROP_DATA_STACK (gCurrentTask->td_StackPtr++)\r
-#define POP_DATA_STACK (*gCurrentTask->td_StackPtr++)\r
-#define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; }\r
-\r
-/* Force Quad alignment. */\r
-#define QUADUP(x) (((x)+3)&~3)\r
-\r
-#define MIN(a,b)  ( ((a)<(b)) ? (a) : (b) )\r
-#define MAX(a,b)  ( ((a)>(b)) ? (a) : (b) )\r
-\r
-\r
-#ifndef TOUCH\r
-       #define TOUCH(argument) ((void)argument)\r
-#endif\r
-\r
-/***************************************************************\r
-** I/O related macros\r
-***************************************************************/\r
-\r
-#define EMIT(c)  ioEmit(c)\r
-#define EMIT_CR  EMIT('\n');\r
-\r
-#define MSG(cs)   pfMessage(cs)\r
-#define ERR(x)    MSG(x)\r
-\r
-#define DBUG(x)  /* PRT(x) */\r
-#define DBUGX(x) /* DBUG(x) */\r
-\r
-#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; }\r
-#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; }\r
-\r
-#define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); }\r
-\r
-#endif  /* _pf_guts_h */\r
+/* @(#) pf_guts.h 98/01/28 1.4 */
+#ifndef _pf_guts_h
+#define _pf_guts_h
+
+/***************************************************************
+** Include file for PForth, a Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+/*
+** PFORTH_VERSION changes when PForth is modified and released.
+** See README file for version info.
+*/
+#define PFORTH_VERSION "27"
+
+/*
+** PFORTH_FILE_VERSION changes when incompatible changes are made
+** in the ".dic" file format.
+**
+** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c".
+** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth().
+** FV5 - 950316 - Added Floats and reserved words.
+** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc.
+** FV7 - 971203 - Added ID_FILL, (1LOCAL@),  etc., ran out of reserved, resorted.
+** FV8 - 980818 - Added Endian flag.
+** FV9 - 20100503 - Added support for 64-bit CELL.
+*/
+#define PF_FILE_VERSION (9)   /* Bump this whenever primitives added. */
+#define PF_EARLIEST_FILE_VERSION (9)  /* earliest one still compatible */
+
+/***************************************************************
+** Sizes and other constants
+***************************************************************/
+
+#define TIB_SIZE (256)
+
+#ifndef FALSE
+    #define FALSE (0)
+#endif
+#ifndef TRUE
+    #define TRUE (1)
+#endif
+
+#define FFALSE (0)
+#define FTRUE (-1)
+#define BLANK (' ')
+
+#define FLAG_PRECEDENCE (0x80)
+#define FLAG_IMMEDIATE  (0x40)
+#define FLAG_SMUDGE     (0x20)
+#define MASK_NAME_SIZE  (0x1F)
+
+/* Debug TRACE flags */
+#define TRACE_INNER     (0x0002)
+#define TRACE_COMPILE   (0x0004)
+#define TRACE_SPECIAL   (0x0008)
+
+/* Numeric types returned by NUMBER? */
+#define NUM_TYPE_BAD    (0)
+#define NUM_TYPE_SINGLE (1)
+#define NUM_TYPE_DOUBLE (2)
+#define NUM_TYPE_FLOAT  (3)
+
+#define CREATE_BODY_OFFSET  (3*sizeof(cell_t))
+
+/***************************************************************
+** Primitive Token IDS
+** Do NOT change the order of these IDs or dictionary files will break!
+***************************************************************/
+enum cforth_primitive_ids
+{
+    ID_EXIT = 0,  /* ID_EXIT must always be zero. */
+/* Do NOT change the order of these IDs or dictionary files will break! */
+    ID_1MINUS,
+    ID_1PLUS,
+    ID_2DUP,
+    ID_2LITERAL,
+    ID_2LITERAL_P,
+    ID_2MINUS,
+    ID_2OVER,
+    ID_2PLUS,
+    ID_2SWAP,
+    ID_2_R_FETCH,
+    ID_2_R_FROM,
+    ID_2_TO_R,
+    ID_ACCEPT_P,
+    ID_ALITERAL,
+    ID_ALITERAL_P,
+    ID_ALLOCATE,
+    ID_AND,
+    ID_ARSHIFT,
+    ID_BAIL,
+    ID_BODY_OFFSET,
+    ID_BRANCH,
+    ID_BYE,
+    ID_CALL_C,
+    ID_CFETCH,
+    ID_CMOVE,
+    ID_CMOVE_UP,
+    ID_COLON,
+    ID_COLON_P,
+    ID_COMPARE,
+    ID_COMP_EQUAL,
+    ID_COMP_GREATERTHAN,
+    ID_COMP_LESSTHAN,
+    ID_COMP_NOT_EQUAL,
+    ID_COMP_U_GREATERTHAN,
+    ID_COMP_U_LESSTHAN,
+    ID_COMP_ZERO_EQUAL,
+    ID_COMP_ZERO_GREATERTHAN,
+    ID_COMP_ZERO_LESSTHAN,
+    ID_COMP_ZERO_NOT_EQUAL,
+    ID_CR,
+    ID_CREATE,
+    ID_CREATE_P,
+    ID_CSTORE,
+    ID_DEFER,
+    ID_DEFER_P,
+    ID_DEPTH,
+    ID_DIVIDE,
+    ID_DOT,
+    ID_DOTS,
+    ID_DO_P,
+    ID_DROP,
+    ID_DUMP,
+    ID_DUP,
+    ID_D_MINUS,
+    ID_D_MTIMES,
+    ID_D_MUSMOD,
+    ID_D_PLUS,
+    ID_D_UMSMOD,
+    ID_D_UMTIMES,
+    ID_EMIT,
+    ID_EMIT_P,
+    ID_EOL,
+    ID_ERRORQ_P,
+    ID_EXECUTE,
+    ID_FETCH,
+    ID_FILE_CLOSE,
+    ID_FILE_CREATE,
+    ID_FILE_OPEN,
+    ID_FILE_POSITION,
+    ID_FILE_READ,
+    ID_FILE_REPOSITION,
+    ID_FILE_RO,
+    ID_FILE_RW,
+    ID_FILE_SIZE,
+    ID_FILE_WRITE,
+    ID_FILL,
+    ID_FIND,
+    ID_FINDNFA,
+    ID_FLUSHEMIT,
+    ID_FREE,
+    ID_HERE,
+    ID_NUMBERQ_P,
+    ID_I,
+    ID_INCLUDE_FILE,
+    ID_J,
+    ID_KEY,
+    ID_LEAVE_P,
+    ID_LITERAL,
+    ID_LITERAL_P,
+    ID_LOADSYS,
+    ID_LOCAL_COMPILER,
+    ID_LOCAL_ENTRY,
+    ID_LOCAL_EXIT,
+    ID_LOCAL_FETCH,
+    ID_LOCAL_FETCH_1,
+    ID_LOCAL_FETCH_2,
+    ID_LOCAL_FETCH_3,
+    ID_LOCAL_FETCH_4,
+    ID_LOCAL_FETCH_5,
+    ID_LOCAL_FETCH_6,
+    ID_LOCAL_FETCH_7,
+    ID_LOCAL_FETCH_8,
+    ID_LOCAL_PLUSSTORE,
+    ID_LOCAL_STORE,
+    ID_LOCAL_STORE_1,
+    ID_LOCAL_STORE_2,
+    ID_LOCAL_STORE_3,
+    ID_LOCAL_STORE_4,
+    ID_LOCAL_STORE_5,
+    ID_LOCAL_STORE_6,
+    ID_LOCAL_STORE_7,
+    ID_LOCAL_STORE_8,
+    ID_LOOP_P,
+    ID_LSHIFT,
+    ID_MAX,
+    ID_MIN,
+    ID_MINUS,
+    ID_NAME_TO_PREVIOUS,
+    ID_NAME_TO_TOKEN,
+    ID_NOOP,
+    ID_NUMBERQ,
+    ID_OR,
+    ID_OVER,
+    ID_PICK,
+    ID_PLUS,
+    ID_PLUSLOOP_P,
+    ID_PLUS_STORE,
+    ID_QDO_P,
+    ID_QDUP,
+    ID_QTERMINAL,
+    ID_QUIT_P,
+    ID_REFILL,
+    ID_RESIZE,
+    ID_RESTORE_INPUT,
+    ID_ROLL,
+    ID_ROT,
+    ID_RP_FETCH,
+    ID_RP_STORE,
+    ID_RSHIFT,
+    ID_R_DROP,
+    ID_R_FETCH,
+    ID_R_FROM,
+    ID_SAVE_FORTH_P,
+    ID_SAVE_INPUT,
+    ID_SCAN,
+    ID_SEMICOLON,
+    ID_SKIP,
+    ID_SOURCE,
+    ID_SOURCE_ID,
+    ID_SOURCE_ID_POP,
+    ID_SOURCE_ID_PUSH,
+    ID_SOURCE_SET,
+    ID_SP_FETCH,
+    ID_SP_STORE,
+    ID_STORE,
+    ID_SWAP,
+    ID_TEST1,
+    ID_TEST2,
+    ID_TEST3,
+    ID_TICK,
+    ID_TIMES,
+    ID_TO_R,
+    ID_TYPE,
+    ID_TYPE_P,
+    ID_VAR_BASE,
+    ID_VAR_CODE_BASE,
+    ID_VAR_CODE_LIMIT,
+    ID_VAR_CONTEXT,
+    ID_VAR_DP,
+    ID_VAR_ECHO,
+    ID_VAR_HEADERS_BASE,
+    ID_VAR_HEADERS_LIMIT,
+    ID_VAR_HEADERS_PTR,
+    ID_VAR_NUM_TIB,
+    ID_VAR_OUT,
+    ID_VAR_RETURN_CODE,
+    ID_VAR_SOURCE_ID,
+    ID_VAR_STATE,
+    ID_VAR_TO_IN,
+    ID_VAR_TRACE_FLAGS,
+    ID_VAR_TRACE_LEVEL,
+    ID_VAR_TRACE_STACK,
+    ID_VLIST,
+    ID_WORD,
+    ID_WORD_FETCH,
+    ID_WORD_STORE,
+    ID_XOR,
+    ID_ZERO_BRANCH,
+    ID_CATCH,
+    ID_THROW,
+    ID_INTERPRET,
+    ID_FILE_WO,
+    ID_FILE_BIN,
+    /* Added to support 64 bit operation. */
+    ID_CELL,
+    ID_CELLS,
+    /* DELETE-FILE */
+    ID_FILE_DELETE,
+/* If you add a word here, take away one reserved word below. */
+#ifdef PF_SUPPORT_FP
+/* Only reserve space if we are adding FP so that we can detect
+** unsupported primitives when loading dictionary.
+*/
+    ID_RESERVED01,
+    ID_RESERVED02,
+    ID_RESERVED03,
+    ID_RESERVED04,
+    ID_RESERVED05,
+    ID_RESERVED06,
+    ID_RESERVED07,
+    ID_RESERVED08,
+    ID_RESERVED09,
+    ID_RESERVED10,
+    ID_RESERVED11,
+    ID_RESERVED12,
+    ID_RESERVED13,
+    ID_FP_D_TO_F,
+    ID_FP_FSTORE,
+    ID_FP_FTIMES,
+    ID_FP_FPLUS,
+    ID_FP_FMINUS,
+    ID_FP_FSLASH,
+    ID_FP_F_ZERO_LESS_THAN,
+    ID_FP_F_ZERO_EQUALS,
+    ID_FP_F_LESS_THAN,
+    ID_FP_F_TO_D,
+    ID_FP_FFETCH,
+    ID_FP_FDEPTH,
+    ID_FP_FDROP,
+    ID_FP_FDUP,
+    ID_FP_FLITERAL,
+    ID_FP_FLITERAL_P,
+    ID_FP_FLOAT_PLUS,
+    ID_FP_FLOATS,
+    ID_FP_FLOOR,
+    ID_FP_FMAX,
+    ID_FP_FMIN,
+    ID_FP_FNEGATE,
+    ID_FP_FOVER,
+    ID_FP_FROT,
+    ID_FP_FROUND,
+    ID_FP_FSWAP,
+    ID_FP_FSTAR_STAR,
+    ID_FP_FABS,
+    ID_FP_FACOS,
+    ID_FP_FACOSH,
+    ID_FP_FALOG,
+    ID_FP_FASIN,
+    ID_FP_FASINH,
+    ID_FP_FATAN,
+    ID_FP_FATAN2,
+    ID_FP_FATANH,
+    ID_FP_FCOS,
+    ID_FP_FCOSH,
+    ID_FP_FLN,
+    ID_FP_FLNP1,
+    ID_FP_FLOG,
+    ID_FP_FSIN,
+    ID_FP_FSINCOS,
+    ID_FP_FSINH,
+    ID_FP_FSQRT,
+    ID_FP_FTAN,
+    ID_FP_FTANH,
+    ID_FP_FPICK,
+#endif
+/* Add new IDs by replacing reserved IDs or extending FP routines. */
+/* Do NOT change the order of these IDs or dictionary files will break! */
+    NUM_PRIMITIVES     /* This must always be LAST */
+};
+
+
+
+/***************************************************************
+** THROW Codes
+***************************************************************/
+/* ANSI standard definitions needed by pForth */
+#define THROW_ABORT            (-1)
+#define THROW_ABORT_QUOTE      (-2)
+#define THROW_STACK_OVERFLOW   (-3)
+#define THROW_STACK_UNDERFLOW  (-4)
+#define THROW_UNDEFINED_WORD  (-13)
+#define THROW_EXECUTING       (-14)
+#define THROW_PAIRS           (-22)
+#define THROW_FLOAT_STACK_UNDERFLOW  ( -45)
+#define THROW_QUIT            (-56)
+
+/* THROW codes unique to pForth */
+#define THROW_BYE            (-256) /* Exit program. */
+#define THROW_SEMICOLON      (-257) /* Error detected at ; */
+#define THROW_DEFERRED       (-258) /* Not a deferred word. Used in system.fth */
+
+/***************************************************************
+** Structures
+***************************************************************/
+
+typedef struct pfTaskData_s
+{
+    cell_t   *td_StackPtr;       /* Primary data stack */
+    cell_t   *td_StackBase;
+    cell_t   *td_StackLimit;
+    cell_t   *td_ReturnPtr;      /* Return stack */
+    cell_t   *td_ReturnBase;
+    cell_t   *td_ReturnLimit;
+#ifdef PF_SUPPORT_FP
+    PF_FLOAT  *td_FloatStackPtr;
+    PF_FLOAT  *td_FloatStackBase;
+    PF_FLOAT  *td_FloatStackLimit;
+#endif
+    cell_t   *td_InsPtr;          /* Instruction pointer, "PC" */
+    FileStream   *td_InputStream;
+/* Terminal. */
+    char    td_TIB[TIB_SIZE];   /* Buffer for terminal input. */
+    cell_t    td_IN;              /* Index into Source */
+    cell_t    td_SourceNum;       /* #TIB after REFILL */
+    char   *td_SourcePtr;       /* Pointer to TIB or other source. */
+    cell_t   td_LineNumber;      /* Incremented on every refill. */
+    cell_t    td_OUT;             /* Current output column. */
+} pfTaskData_t;
+
+typedef struct pfNode
+{
+    struct pfNode *n_Next;
+    struct pfNode *n_Prev;
+} pfNode;
+
+/* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/
+typedef struct cfNameLinks
+{
+    cell_t       cfnl_PreviousName;   /* name relative address of previous */
+    ExecToken  cfnl_ExecToken;      /* Execution token for word. */
+/* Followed by variable length name field. */
+} cfNameLinks;
+
+#define PF_DICF_ALLOCATED_SEGMENTS  ( 0x0001)
+typedef struct pfDictionary_s
+{
+    pfNode  dic_Node;
+    ucell_t  dic_Flags;
+/* Headers contain pointers to names and dictionary. */
+
+    ucell_t dic_HeaderBaseUnaligned;
+
+    ucell_t dic_HeaderBase;
+    ucell_t dic_HeaderPtr;
+    ucell_t dic_HeaderLimit;
+/* Code segment contains tokenized code and data. */
+    ucell_t dic_CodeBaseUnaligned;
+    ucell_t dic_CodeBase;
+    union
+    {
+        cell_t  *Cell;
+        uint8_t *Byte;
+    } dic_CodePtr;
+    ucell_t dic_CodeLimit;
+} pfDictionary_t;
+
+/* Save state of include when nesting files. */
+typedef struct IncludeFrame
+{
+    FileStream   *inf_FileID;
+    cell_t         inf_LineNumber;
+    cell_t         inf_SourceNum;
+    cell_t         inf_IN;
+    char          inf_SaveTIB[TIB_SIZE];
+} IncludeFrame;
+
+#define MAX_INCLUDE_DEPTH (16)
+
+/***************************************************************
+** Prototypes
+***************************************************************/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+int pfCatch( ExecToken XT );
+
+#ifdef __cplusplus
+}
+#endif
+
+/***************************************************************
+** External Globals
+***************************************************************/
+extern pfTaskData_t *gCurrentTask;
+extern pfDictionary_t *gCurrentDictionary;
+extern char          gScratch[TIB_SIZE];
+extern cell_t         gNumPrimitives;
+
+extern ExecToken     gLocalCompiler_XT;      /* CFA of (LOCAL) compiler. */
+extern ExecToken     gNumberQ_XT;         /* XT of NUMBER? */
+extern ExecToken     gQuitP_XT;           /* XT of (QUIT) */
+extern ExecToken     gAcceptP_XT;         /* XT of ACCEPT */
+
+#define DEPTH_AT_COLON_INVALID (-100)
+extern cell_t         gDepthAtColon;
+
+/* Global variables. */
+extern cell_t        gVarContext;    /* Points to last name field. */
+extern cell_t        gVarState;      /* 1 if compiling. */
+extern cell_t        gVarBase;       /* Numeric Base. */
+extern cell_t        gVarEcho;       /* Echo input from file. */
+extern cell_t        gVarEchoAccept; /* Echo input from ACCEPT. */
+extern cell_t        gVarTraceLevel;
+extern cell_t        gVarTraceStack;
+extern cell_t        gVarTraceFlags;
+extern cell_t        gVarQuiet;      /* Suppress unnecessary messages, OK, etc. */
+extern cell_t        gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
+
+extern IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];
+extern cell_t         gIncludeIndex;
+/***************************************************************
+** Macros
+***************************************************************/
+
+
+/* Endian specific macros for creating target dictionaries for machines with
+
+** different endian-ness.
+
+*/
+
+#if defined(PF_BIG_ENDIAN_DIC)
+
+#define WRITE_FLOAT_DIC             WriteFloatBigEndian
+#define WRITE_CELL_DIC(addr,data)   WriteCellBigEndian((uint8_t *)(addr),(ucell_t)(data))
+#define WRITE_SHORT_DIC(addr,data)  Write16BigEndian((uint8_t *)(addr),(uint16_t)(data))
+#define READ_FLOAT_DIC              ReadFloatBigEndian
+#define READ_CELL_DIC(addr)         ReadCellBigEndian((const uint8_t *)(addr))
+#define READ_SHORT_DIC(addr)        Read16BigEndian((const uint8_t *)(addr))
+
+#elif defined(PF_LITTLE_ENDIAN_DIC)
+
+#define WRITE_FLOAT_DIC             WriteFloatLittleEndian
+#define WRITE_CELL_DIC(addr,data)   WriteCellLittleEndian((uint8_t *)(addr),(ucell_t)(data))
+#define WRITE_SHORT_DIC(addr,data)  Write16LittleEndian((uint8_t *)(addr),(uint16_t)(data))
+#define READ_FLOAT_DIC              ReadFloatLittleEndian
+#define READ_CELL_DIC(addr)         ReadCellLittleEndian((const uint8_t *)(addr))
+#define READ_SHORT_DIC(addr)        Read16LittleEndian((const uint8_t *)(addr))
+
+#else
+
+#define WRITE_FLOAT_DIC(addr,data)  { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); }
+#define WRITE_CELL_DIC(addr,data)   { *((cell_t *)(addr)) = (cell_t)(data); }
+#define WRITE_SHORT_DIC(addr,data)  { *((int16_t *)(addr)) = (int16_t)(data); }
+#define READ_FLOAT_DIC(addr)        ( *((PF_FLOAT *)(addr)) )
+#define READ_CELL_DIC(addr)         ( *((const ucell_t *)(addr)) )
+#define READ_SHORT_DIC(addr)        ( *((const uint16_t *)(addr)) )
+
+#endif
+
+
+#define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell)
+#define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell)
+#define CODE_COMMA( N ) WRITE_CELL_DIC(CODE_HERE++,(N))
+#define NAME_BASE (gCurrentDictionary->dic_HeaderBase)
+#define CODE_BASE (gCurrentDictionary->dic_CodeBase)
+#define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase)
+#define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase)
+
+#define IN_CODE_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_CodeBase)   && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_CodeLimit) )
+
+#define IN_NAME_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_HeaderLimit) )
+#define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr))
+
+/* Address conversion */
+#define ABS_TO_NAMEREL( a ) ((cell_t)  (((ucell_t) a) - NAME_BASE ))
+#define ABS_TO_CODEREL( a ) ((cell_t)  (((ucell_t) a) - CODE_BASE ))
+#define NAMEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + NAME_BASE))
+#define CODEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + CODE_BASE))
+
+/* The check for >0 is only needed for CLONE testing. !!! */
+#define IsTokenPrimitive(xt) ((xt<gNumPrimitives) && (xt>=0))
+
+#define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } }
+
+#define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr)
+#define DROP_DATA_STACK (gCurrentTask->td_StackPtr++)
+#define POP_DATA_STACK (*gCurrentTask->td_StackPtr++)
+#define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; }
+
+/* Force Quad alignment. */
+#define QUADUP(x) (((x)+3)&~3)
+
+#define MIN(a,b)  ( ((a)<(b)) ? (a) : (b) )
+#define MAX(a,b)  ( ((a)>(b)) ? (a) : (b) )
+
+
+#ifndef TOUCH
+    #define TOUCH(argument) ((void)argument)
+#endif
+
+/***************************************************************
+** I/O related macros
+***************************************************************/
+
+#define EMIT(c)  ioEmit(c)
+#define EMIT_CR  EMIT('\n');
+
+#define MSG(cs)   pfMessage(cs)
+#define ERR(x)    MSG(x)
+
+#define DBUG(x)  /* PRT(x) */
+#define DBUGX(x) /* DBUG(x) */
+
+#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; }
+#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; }
+
+#define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); }
+
+#endif  /* _pf_guts_h */

diff --git a/csrc/pf_host.h b/csrc/pf_host.h
index 00e7dcb..c95b16f 100644 (file)
--- a/csrc/pf_host.h
+++ b/csrc/pf_host.h
@@ -1,24 +1,24 @@
-/* @(#) pf_host.h 96/12/18 1.12 */\r
-#ifndef _pf_system_h\r
-#define _pf_system_h\r
-\r
-/***************************************************************\r
-** System Dependant Includes for PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-***************************************************************/\r
-\r
-#endif /* _pf_system_h */\r
-\r
+/* @(#) pf_host.h 96/12/18 1.12 */
+#ifndef _pf_system_h
+#define _pf_system_h
+
+/***************************************************************
+** System Dependant Includes for PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+***************************************************************/
+
+#endif /* _pf_system_h */
+

diff --git a/csrc/pf_inc1.h b/csrc/pf_inc1.h
index e391841..ba3f417 100644 (file)
--- a/csrc/pf_inc1.h
+++ b/csrc/pf_inc1.h
@@ -1,44 +1,44 @@
-/*  @(#) pf_unix.h 98/01/28 1.4 */\r
-#ifndef _pf_embedded_h\r
-#define _pf_embedded_h\r
-\r
-/***************************************************************\r
-** Embedded System include file for PForth, a Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#ifndef PF_NO_CLIB\r
-       #include <string.h>    /* Needed for strlen(), memcpy(), and memset(). */\r
-       #include <stdlib.h>    /* Needed for exit(). */\r
-#endif\r
-\r
-#ifdef PF_NO_STDIO\r
-       #define NULL  ((void *) 0)\r
-       #define EOF   (-1)\r
-#else\r
-       #include <stdio.h>\r
-#endif\r
-\r
-#ifdef PF_SUPPORT_FP\r
-       #include <math.h>\r
-\r
-       #ifndef PF_USER_FP\r
-               #include "pf_float.h"\r
-       #else\r
-               #include PF_USER_FP\r
-       #endif\r
-#endif\r
-\r
-#endif /* _pf_embedded_h */\r
+/*  @(#) pf_unix.h 98/01/28 1.4 */
+#ifndef _pf_embedded_h
+#define _pf_embedded_h
+
+/***************************************************************
+** Embedded System include file for PForth, a Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#ifndef PF_NO_CLIB
+    #include <string.h>    /* Needed for strlen(), memcpy(), and memset(). */
+    #include <stdlib.h>    /* Needed for exit(). */
+#endif
+
+#ifdef PF_NO_STDIO
+    #define NULL  ((void *) 0)
+    #define EOF   (-1)
+#else
+    #include <stdio.h>
+#endif
+
+#ifdef PF_SUPPORT_FP
+    #include <math.h>
+
+    #ifndef PF_USER_FP
+        #include "pf_float.h"
+    #else
+        #include PF_USER_FP
+    #endif
+#endif
+
+#endif /* _pf_embedded_h */

diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c
index dc9c719..d616c22 100644 (file)
--- a/csrc/pf_inner.c
+++ b/csrc/pf_inner.c
@@ -1,1803 +1,1803 @@
-/* @(#) pf_inner.c 98/03/16 1.7 */\r
-/***************************************************************\r
-** Inner Interpreter for Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-**\r
-** 940502 PLB Creation.\r
-** 940505 PLB More macros.\r
-** 940509 PLB Moved all stack stuff into pfCatch.\r
-** 941014 PLB Converted to flat secondary strusture.\r
-** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH, \r
-**             and ID_HERE for armcc\r
-** 941130 PLB Made w@ unsigned\r
-**\r
-***************************************************************/\r
-\r
-#include <sys/types.h>\r
-\r
-#include "pf_all.h"\r
-\r
-#if defined(WIN32) && !defined(__MINGW32__)\r
-#include <crtdbg.h>\r
-#endif\r
-\r
-#define SYSTEM_LOAD_FILE "system.fth"\r
-\r
-/***************************************************************\r
-** Macros for data stack access.\r
-** TOS is cached in a register in pfCatch.\r
-***************************************************************/\r
-\r
-#define STKPTR   (DataStackPtr)\r
-#define M_POP    (*(STKPTR++))\r
-#define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}\r
-#define M_STACK(n) (STKPTR[n])\r
-\r
-#define TOS      (TopOfStack)\r
-#define PUSH_TOS M_PUSH(TOS)\r
-#define M_DUP    PUSH_TOS;\r
-#define M_DROP   { TOS = M_POP; }\r
-\r
-\r
-/***************************************************************\r
-** Macros for Floating Point stack access.\r
-***************************************************************/\r
-#ifdef PF_SUPPORT_FP\r
-#define FP_STKPTR   (FloatStackPtr)\r
-#define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)\r
-#define M_FP_POP    (*(FP_STKPTR++))\r
-#define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}\r
-#define M_FP_STACK(n) (FP_STKPTR[n])\r
-\r
-#define FP_TOS      (fpTopOfStack)\r
-#define PUSH_FP_TOS M_FP_PUSH(FP_TOS)\r
-#define M_FP_DUP    PUSH_FP_TOS;\r
-#define M_FP_DROP   { FP_TOS = M_FP_POP; }\r
-#endif\r
-\r
-/***************************************************************\r
-** Macros for return stack access.\r
-***************************************************************/\r
-\r
-#define TORPTR (ReturnStackPtr)\r
-#define M_R_DROP {TORPTR++;}\r
-#define M_R_POP (*(TORPTR++))\r
-#define M_R_PICK(n) (TORPTR[n])\r
-#define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}\r
-\r
-/***************************************************************\r
-** Misc Forth macros\r
-***************************************************************/\r
-                       \r
-#define M_BRANCH   { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }\r
-\r
-/* Cache top of data stack like in JForth. */\r
-#ifdef PF_SUPPORT_FP\r
-#define LOAD_REGISTERS \\r
-       { \\r
-               STKPTR = gCurrentTask->td_StackPtr; \\r
-               TOS = M_POP; \\r
-               FP_STKPTR = gCurrentTask->td_FloatStackPtr; \\r
-               FP_TOS = M_FP_POP; \\r
-               TORPTR = gCurrentTask->td_ReturnPtr; \\r
-        }\r
-        \r
-#define SAVE_REGISTERS \\r
-       { \\r
-               gCurrentTask->td_ReturnPtr = TORPTR; \\r
-               M_PUSH( TOS ); \\r
-               gCurrentTask->td_StackPtr = STKPTR; \\r
-               M_FP_PUSH( FP_TOS ); \\r
-               gCurrentTask->td_FloatStackPtr = FP_STKPTR; \\r
-        }\r
-        \r
-#else\r
-/* Cache top of data stack like in JForth. */\r
-#define LOAD_REGISTERS \\r
-       { \\r
-               STKPTR = gCurrentTask->td_StackPtr; \\r
-               TOS = M_POP; \\r
-               TORPTR = gCurrentTask->td_ReturnPtr; \\r
-        }\r
-        \r
-#define SAVE_REGISTERS \\r
-       { \\r
-               gCurrentTask->td_ReturnPtr = TORPTR; \\r
-               M_PUSH( TOS ); \\r
-               gCurrentTask->td_StackPtr = STKPTR; \\r
-        }\r
-#endif\r
-\r
-#define M_DOTS \\r
-       SAVE_REGISTERS; \\r
-       ffDotS( ); \\r
-       LOAD_REGISTERS;\r
-       \r
-#define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }\r
-\r
-#ifdef PF_SUPPORT_FP\r
-#define M_THROW(err) \\r
-       { \\r
-               ExceptionReturnCode = (ThrowCode)(err); \\r
-               TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \\r
-               STKPTR = InitialDataStack; \\r
-               FP_STKPTR = InitialFloatStack; \\r
-       }\r
-#else\r
-#define M_THROW(err) \\r
-       { \\r
-               ExceptionReturnCode = (err); \\r
-               TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \\r
-               STKPTR = InitialDataStack; \\r
-       }\r
-#endif\r
-\r
-/***************************************************************\r
-** Other macros\r
-***************************************************************/\r
-\r
-#define BINARY_OP( op ) { TOS = M_POP op TOS; }\r
-#define endcase break\r
-               \r
-#if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)\r
-       #define TRACENAMES /* no names */\r
-#else\r
-/* Display name of executing routine. */\r
-static void TraceNames( ExecToken Token, cell_t Level )\r
-{\r
-       char *DebugName;\r
-       cell_t i;\r
-       \r
-       if( ffTokenToName( Token, &DebugName ) )\r
-       {\r
-               cell_t NumSpaces;\r
-               if( gCurrentTask->td_OUT > 0 ) EMIT_CR;\r
-               EMIT( '>' );\r
-               for( i=0; i<Level; i++ )\r
-               {\r
-                       MSG( "  " );\r
-               }\r
-               TypeName( DebugName );\r
-/* Space out to column N then .S */\r
-               NumSpaces = 30 - gCurrentTask->td_OUT;\r
-               for( i=0; i < NumSpaces; i++ )\r
-               {\r
-                       EMIT( ' ' );\r
-               }\r
-               ffDotS();\r
-/* No longer needed?           gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */\r
-               \r
-       }\r
-       else\r
-       {\r
-               MSG_NUM_H("Couldn't find Name for ", Token);\r
-       }\r
-}\r
-\r
-#define TRACENAMES \\r
-       if( (gVarTraceLevel > Level) ) \\r
-       { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }\r
-#endif /* PF_NO_SHELL */\r
-\r
-/* Use local copy of CODE_BASE for speed. */\r
-#define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))\r
-\r
-static const char *pfSelectFileModeCreate( int fam );\r
-static const char *pfSelectFileModeOpen( int fam );\r
-\r
-/**************************************************************/\r
-static const char *pfSelectFileModeCreate( int fam )\r
-{\r
-       const char *famText = NULL;\r
-       switch( fam )\r
-       {\r
-       case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):\r
-               famText = PF_FAM_BIN_CREATE_WO;\r
-               break;\r
-       case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):\r
-               famText = PF_FAM_BIN_CREATE_RW;\r
-               break;\r
-       case PF_FAM_WRITE_ONLY:\r
-               famText = PF_FAM_CREATE_WO;\r
-               break;\r
-       case PF_FAM_READ_WRITE:\r
-               famText = PF_FAM_CREATE_RW;\r
-               break;\r
-       default:\r
-               famText = "illegal";\r
-               break;\r
-       }\r
-       return famText;\r
-}\r
-\r
-/**************************************************************/\r
-static const char *pfSelectFileModeOpen( int fam )\r
-{\r
-       const char *famText = NULL;\r
-       switch( fam )\r
-       {\r
-       case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):\r
-               famText = PF_FAM_BIN_OPEN_RO;\r
-               break;\r
-       case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):\r
-               famText = PF_FAM_BIN_CREATE_WO;\r
-               break;\r
-       case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):\r
-               famText = PF_FAM_BIN_OPEN_RW;\r
-               break;\r
-       case PF_FAM_READ_ONLY:\r
-               famText = PF_FAM_OPEN_RO;\r
-               break;\r
-       case PF_FAM_WRITE_ONLY:\r
-               famText = PF_FAM_CREATE_WO;\r
-               break;\r
-       case PF_FAM_READ_WRITE:\r
-       default:\r
-               famText = PF_FAM_OPEN_RW;\r
-               break;\r
-       }\r
-       return famText;\r
-}\r
-\r
-/**************************************************************/\r
-int pfCatch( ExecToken XT )\r
-{\r
-       register cell_t  TopOfStack;    /* Cache for faster execution. */\r
-       register cell_t *DataStackPtr;\r
-       register cell_t *ReturnStackPtr;\r
-       register cell_t *InsPtr = NULL;\r
-       register cell_t  Token;\r
-       cell_t           Scratch;\r
-       \r
-#ifdef PF_SUPPORT_FP\r
-       PF_FLOAT       fpTopOfStack;\r
-       PF_FLOAT      *FloatStackPtr;\r
-       PF_FLOAT       fpScratch;\r
-       PF_FLOAT       fpTemp;\r
-       PF_FLOAT      *InitialFloatStack;\r
-#endif\r
-#ifdef PF_SUPPORT_TRACE\r
-       cell_t Level = 0;\r
-#endif\r
-       cell_t        *LocalsPtr = NULL;\r
-       cell_t         Temp;\r
-       cell_t        *InitialReturnStack;\r
-       cell_t        *InitialDataStack;\r
-       cell_t         FakeSecondary[2];\r
-       char          *CharPtr;\r
-       cell_t        *CellPtr;\r
-       FileStream    *FileID;\r
-       uint8_t       *CodeBase = (uint8_t *) CODE_BASE;\r
-       ThrowCode      ExceptionReturnCode = 0;\r
-       \r
-/* FIXME\r
-       gExecutionDepth += 1;\r
-       PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));\r
-*/\r
-\r
-/*\r
-** Initialize FakeSecondary this way to avoid having stuff in the data section,\r
-** which is not supported for some embedded system loaders.\r
-*/\r
-       FakeSecondary[0] = 0;\r
-       FakeSecondary[1] = ID_EXIT; /* For EXECUTE */\r
-\r
-/* Move data from task structure to registers for speed. */\r
-       LOAD_REGISTERS;\r
-\r
-/* Save initial stack depths for THROW */\r
-       InitialReturnStack = TORPTR;\r
-       InitialDataStack   = STKPTR ;\r
-#ifdef PF_SUPPORT_FP\r
-       InitialFloatStack  = FP_STKPTR;\r
-#endif\r
-\r
-       Token = XT;\r
-\r
-       do\r
-       {\r
-DBUG(("pfCatch: Token = 0x%x\n", Token ));\r
-\r
-/* --------------------------------------------------------------- */\r
-/* If secondary, thread down code tree until we hit a primitive. */\r
-               while( !IsTokenPrimitive( Token ) )\r
-               {\r
-#ifdef PF_SUPPORT_TRACE\r
-                       if((gVarTraceFlags & TRACE_INNER) )\r
-                       {\r
-                               MSG("pfCatch: Secondary Token = 0x");\r
-                               ffDotHex(Token);\r
-                               MSG_NUM_H(", InsPtr = 0x", InsPtr);\r
-                       }\r
-                       TRACENAMES;\r
-#endif\r
-\r
-/* Save IP on return stack like a JSR. */\r
-                       M_R_PUSH( InsPtr );\r
-                       \r
-/* Convert execution token to absolute address. */\r
-                       InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );\r
-\r
-/* Fetch token at IP. */\r
-                       Token = READ_CELL_DIC(InsPtr++);\r
-                       \r
-#ifdef PF_SUPPORT_TRACE\r
-/* Bump level for trace display */\r
-                       Level++;\r
-#endif\r
-               }\r
-\r
-               \r
-#ifdef PF_SUPPORT_TRACE\r
-               TRACENAMES;\r
-#endif\r
-                       \r
-/* Execute primitive Token. */\r
-               switch( Token )\r
-               {\r
-                       \r
-       /* Pop up a level in Forth inner interpreter.\r
-       ** Used to implement semicolon.\r
-       ** Put first in switch because ID_EXIT==0 */\r
-               case ID_EXIT:\r
-                       InsPtr = ( cell_t *) M_R_POP;\r
-#ifdef PF_SUPPORT_TRACE\r
-                       Level--;\r
-#endif\r
-                       endcase;\r
-                                               \r
-               case ID_1MINUS:  TOS--; endcase;\r
-                       \r
-               case ID_1PLUS:   TOS++; endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_2LITERAL:\r
-                       ff2Literal( TOS, M_POP );\r
-                       M_DROP;\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_2LITERAL_P:\r
-/* hi part stored first, put on top of stack */\r
-                       PUSH_TOS;\r
-                       TOS = READ_CELL_DIC(InsPtr++);\r
-                       M_PUSH(READ_CELL_DIC(InsPtr++));\r
-                       endcase;\r
-                       \r
-               case ID_2MINUS:  TOS -= 2; endcase;\r
-                       \r
-               case ID_2PLUS:   TOS += 2; endcase;\r
-               \r
-               \r
-               case ID_2OVER:  /* ( a b c d -- a b c d a b ) */\r
-                       PUSH_TOS;\r
-                       Scratch = M_STACK(3);\r
-                       M_PUSH(Scratch);\r
-                       TOS = M_STACK(3);\r
-                       endcase;\r
-                       \r
-               case ID_2SWAP:  /* ( a b c d -- c d a b ) */\r
-                       Scratch = M_STACK(0);    /* c */\r
-                       M_STACK(0) = M_STACK(2); /* a */\r
-                       M_STACK(2) = Scratch;    /* c */\r
-                       Scratch = TOS;           /* d */\r
-                       TOS = M_STACK(1);        /* b */\r
-                       M_STACK(1) = Scratch;    /* d */\r
-                       endcase;\r
-                       \r
-               case ID_2DUP:   /* ( a b -- a b a b ) */\r
-                       PUSH_TOS;\r
-                       Scratch = M_STACK(1);\r
-                       M_PUSH(Scratch);\r
-                       endcase;\r
-                       \r
-               case ID_2_R_FETCH:\r
-                       PUSH_TOS;\r
-                       M_PUSH( (*(TORPTR+1)) );\r
-                       TOS = (*(TORPTR));\r
-                       endcase;\r
-\r
-               case ID_2_R_FROM:\r
-                       PUSH_TOS;\r
-                       TOS = M_R_POP;\r
-                       M_PUSH( M_R_POP );\r
-                       endcase;\r
-\r
-               case ID_2_TO_R:\r
-                       M_R_PUSH( M_POP );\r
-                       M_R_PUSH( TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-               \r
-               case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */\r
-                       CharPtr = (char *) M_POP;\r
-                       TOS = ioAccept( CharPtr, TOS );\r
-                       endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_ALITERAL:\r
-                       ffALiteral( ABS_TO_CODEREL(TOS) );\r
-                       M_DROP;\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_ALITERAL_P:\r
-                       PUSH_TOS;\r
-                       TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );\r
-                       endcase;\r
-                       \r
-/* Allocate some extra and put validation identifier at base */\r
-#define PF_MEMORY_VALIDATOR  (0xA81B4D69)\r
-               case ID_ALLOCATE:\r
-                       /* Allocate at least one cell's worth because we clobber first cell. */\r
-                       if ( TOS < sizeof(cell_t) )\r
-                       {\r
-                               Temp = sizeof(cell_t);\r
-                       }\r
-                       else\r
-                       {\r
-                               Temp = TOS;\r
-                       }\r
-                       /* Allocate extra cells worth because we store validation info. */\r
-                       CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );\r
-                       if( CellPtr )\r
-                       {\r
-/* This was broken into two steps because different compilers incremented\r
-** CellPtr before or after the XOR step. */\r
-                               Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;\r
-                               *CellPtr++ = Temp;\r
-                               M_PUSH( (cell_t) CellPtr );\r
-                               TOS = 0;\r
-                       }\r
-                       else\r
-                       {\r
-                               M_PUSH( 0 );\r
-                               TOS = -1;  /* FIXME Fix error code. */\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_AND:     BINARY_OP( & ); endcase;\r
-               \r
-               case ID_ARSHIFT:     BINARY_OP( >> ); endcase;  /* Arithmetic right shift */\r
-               \r
-               case ID_BODY_OFFSET:\r
-                       PUSH_TOS;\r
-                       TOS = CREATE_BODY_OFFSET;\r
-                       endcase;\r
-                       \r
-/* Branch is followed by an offset relative to address of offset. */\r
-               case ID_BRANCH:\r
-DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));\r
-                       M_BRANCH;\r
-DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));\r
-                       endcase;\r
-\r
-               case ID_BYE:\r
-                       M_THROW( THROW_BYE );\r
-                       endcase;\r
-\r
-               case ID_BAIL:\r
-                       MSG("Emergency exit.\n");\r
-                       EXIT(1);\r
-                       endcase;\r
-               \r
-               case ID_CATCH:\r
-                       Scratch = TOS;\r
-                       TOS = M_POP;\r
-                       SAVE_REGISTERS;\r
-                       Scratch = pfCatch( Scratch );\r
-                       LOAD_REGISTERS;\r
-                       M_PUSH( TOS );\r
-                       TOS = Scratch;\r
-                       endcase;\r
-\r
-               case ID_CALL_C:\r
-                       SAVE_REGISTERS;\r
-                       Scratch = READ_CELL_DIC(InsPtr++);\r
-                       CallUserFunction( Scratch & 0xFFFF,\r
-                               (Scratch >> 31) & 1,\r
-                               (Scratch >> 24) & 0x7F );\r
-                       LOAD_REGISTERS;\r
-                       endcase;\r
-                               \r
-               /* Support 32/64 bit operation. */\r
-               case ID_CELL:\r
-                               M_PUSH( TOS );\r
-                               TOS = sizeof(cell_t);\r
-                               endcase;\r
-                               \r
-               case ID_CELLS:\r
-                               TOS = TOS * sizeof(cell_t);\r
-                               endcase;\r
-                               \r
-               case ID_CFETCH:   TOS = *((uint8_t *) TOS); endcase;\r
-\r
-               case ID_CMOVE: /* ( src dst n -- ) */\r
-                       {\r
-                               register char *DstPtr = (char *) M_POP; /* dst */\r
-                               CharPtr = (char *) M_POP;    /* src */\r
-                               for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r
-                               {\r
-                                       *DstPtr++ = *CharPtr++;\r
-                               }\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-                       \r
-               case ID_CMOVE_UP: /* ( src dst n -- ) */\r
-                       {\r
-                               register char *DstPtr = ((char *) M_POP) + TOS; /* dst */\r
-                               CharPtr = ((char *) M_POP) + TOS;;    /* src */\r
-                               for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r
-                               {\r
-                                       *(--DstPtr) = *(--CharPtr);\r
-                               }\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-               \r
-#ifndef PF_NO_SHELL\r
-               case ID_COLON:\r
-                       SAVE_REGISTERS;\r
-                       ffColon( );\r
-                       LOAD_REGISTERS;\r
-                       endcase;\r
-               case ID_COLON_P:  /* ( $name xt -- ) */\r
-                       CreateDicEntry( TOS, (char *) M_POP, 0 );\r
-                       M_DROP;\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_COMPARE:\r
-                       {\r
-                               const char *s1, *s2;\r
-                               cell_t len1;\r
-                               s2 = (const char *) M_POP;\r
-                               len1 = M_POP;\r
-                               s1 = (const char *) M_POP;\r
-                               TOS = ffCompare( s1, len1, s2, TOS );\r
-                       }\r
-                       endcase;\r
-                       \r
-/* ( a b -- flag , Comparisons ) */\r
-               case ID_COMP_EQUAL:\r
-                       TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_NOT_EQUAL:\r
-                       TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_GREATERTHAN:\r
-                       TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_LESSTHAN:\r
-                       TOS = (  M_POP < TOS ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_U_GREATERTHAN:\r
-                       TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_U_LESSTHAN:\r
-                       TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_ZERO_EQUAL:\r
-                       TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_ZERO_NOT_EQUAL:\r
-                       TOS = ( TOS != 0 ) ? FTRUE : FALSE ;\r
-                       endcase;\r
-               case ID_COMP_ZERO_GREATERTHAN:\r
-                       TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-               case ID_COMP_ZERO_LESSTHAN:\r
-                       TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;\r
-                       endcase;\r
-                       \r
-               case ID_CR:\r
-                       EMIT_CR;\r
-                       endcase;\r
-               \r
-#ifndef PF_NO_SHELL\r
-               case ID_CREATE:\r
-                       SAVE_REGISTERS;\r
-                       ffCreate();\r
-                       LOAD_REGISTERS;\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_CREATE_P:\r
-                       PUSH_TOS;\r
-/* Put address of body on stack.  Insptr points after code start. */\r
-                       TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );\r
-                       endcase;\r
-       \r
-               case ID_CSTORE: /* ( c caddr -- ) */\r
-                       *((uint8_t *) TOS) = (uint8_t) M_POP;\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-/* Double precision add. */\r
-               case ID_D_PLUS:  /* D+ ( al ah bl bh -- sl sh ) */ \r
-                       {\r
-                               register ucell_t ah,al,bl,sh,sl;\r
-#define bh TOS\r
-                               bl = M_POP;\r
-                               ah = M_POP;\r
-                               al = M_POP;\r
-                               sh = 0;\r
-                               sl = al + bl;\r
-                               if( sl < bl ) sh = 1; /* Carry */\r
-                               sh += ah + bh;\r
-                               M_PUSH( sl );\r
-                               TOS = sh;\r
-#undef bh\r
-                       }\r
-                       endcase;\r
-       \r
-/* Double precision subtract. */\r
-               case ID_D_MINUS:  /* D- ( al ah bl bh -- sl sh ) */ \r
-                       {\r
-                               register ucell_t ah,al,bl,sh,sl;\r
-#define bh TOS\r
-                               bl = M_POP;\r
-                               ah = M_POP;\r
-                               al = M_POP;\r
-                               sh = 0;\r
-                               sl = al - bl;\r
-                               if( al < bl ) sh = 1; /* Borrow */\r
-                               sh = ah - bh - sh;\r
-                               M_PUSH( sl );\r
-                               TOS = sh;\r
-#undef bh\r
-                       }\r
-                       endcase;\r
-                       \r
-/* Assume 8-bit char and calculate cell width. */\r
-#define NBITS ((sizeof(ucell_t)) * 8)\r
-/* Define half the number of bits in a cell. */\r
-#define HNBITS (NBITS / 2)\r
-/* Assume two-complement arithmetic to calculate lower half. */\r
-#define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))\r
-#define HIGH_BIT ((ucell_t)1 << (NBITS - 1))\r
-\r
-/* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.\r
- * Using an improved algorithm suggested by Steve Green.\r
- * Converted to 64-bit by Aleksej Saushev.\r
- */\r
-               case ID_D_UMTIMES:  /* UM* ( a b -- lo hi ) */ \r
-                       {\r
-                               ucell_t ahi, alo, bhi, blo; /* input parts */\r
-                               ucell_t lo, hi, temp;\r
-/* Get values from stack. */\r
-                               ahi = M_POP;\r
-                               bhi = TOS;\r
-/* Break into hi and lo 16 bit parts. */\r
-                               alo = LOWER_HALF(ahi);\r
-                               ahi = ahi >> HNBITS;\r
-                               blo = LOWER_HALF(bhi);\r
-                               bhi = bhi >> HNBITS;\r
-\r
-                               lo = 0;\r
-                               hi = 0;\r
-/* higher part: ahi * bhi */\r
-                               hi += ahi * bhi;\r
-/* middle (overlapping) part: ahi * blo */\r
-                               temp = ahi * blo;\r
-                               lo += LOWER_HALF(temp);\r
-                               hi += temp >> HNBITS;\r
-/* middle (overlapping) part: alo * bhi  */\r
-                               temp = alo * bhi;\r
-                               lo += LOWER_HALF(temp);\r
-                               hi += temp >> HNBITS;\r
-/* lower part: alo * blo */\r
-                               temp = alo * blo;\r
-/* its higher half overlaps with middle's lower half: */\r
-                               lo += temp >> HNBITS;\r
-/* process carry: */\r
-                               hi += lo >> HNBITS;\r
-                               lo = LOWER_HALF(lo);\r
-/* combine lower part of result: */\r
-                               lo = (lo << HNBITS) + LOWER_HALF(temp);\r
-\r
-                               M_PUSH( lo );\r
-                               TOS = hi;\r
-                       }\r
-                       endcase;\r
-                       \r
-/* Perform cell*cell bit multiply for 2 cell result, using shift and add. */\r
-               case ID_D_MTIMES:  /* M* ( a b -- pl ph ) */ \r
-                       {\r
-                               ucell_t ahi, alo, bhi, blo; /* input parts */\r
-                               ucell_t lo, hi, temp;\r
-                               int sg;\r
-/* Get values from stack. */\r
-                               ahi = M_POP;\r
-                               bhi = TOS;\r
-\r
-/* Calculate product sign: */\r
-                               sg = ((cell_t)(ahi ^ bhi) < 0);\r
-/* Take absolute values and reduce to um* */\r
-                               if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);\r
-                               if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);\r
-\r
-/* Break into hi and lo 16 bit parts. */\r
-                               alo = LOWER_HALF(ahi);\r
-                               ahi = ahi >> HNBITS;\r
-                               blo = LOWER_HALF(bhi);\r
-                               bhi = bhi >> HNBITS;\r
-\r
-                               lo = 0;\r
-                               hi = 0;\r
-/* higher part: ahi * bhi */\r
-                               hi += ahi * bhi;\r
-/* middle (overlapping) part: ahi * blo */\r
-                               temp = ahi * blo;\r
-                               lo += LOWER_HALF(temp);\r
-                               hi += temp >> HNBITS;\r
-/* middle (overlapping) part: alo * bhi  */\r
-                               temp = alo * bhi;\r
-                               lo += LOWER_HALF(temp);\r
-                               hi += temp >> HNBITS;\r
-/* lower part: alo * blo */\r
-                               temp = alo * blo;\r
-/* its higher half overlaps with middle's lower half: */\r
-                               lo += temp >> HNBITS;\r
-/* process carry: */\r
-                               hi += lo >> HNBITS;\r
-                               lo = LOWER_HALF(lo);\r
-/* combine lower part of result: */\r
-                               lo = (lo << HNBITS) + LOWER_HALF(temp);\r
-\r
-/* Negate product if one operand negative. */\r
-                               if(sg)\r
-                               {\r
-                                       /* lo = (ucell_t)(- lo); */\r
-                                       lo = ~lo + 1;\r
-                                       hi = ~hi + ((lo == 0) ? 1 : 0);\r
-                               }\r
-\r
-                               M_PUSH( lo );\r
-                               TOS = hi;\r
-                       }\r
-                       endcase;\r
-\r
-#define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )\r
-/* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */\r
-               case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */ \r
-                       {\r
-                               ucell_t ah,al, q,di, bl,bh, sl,sh;\r
-                               ah = M_POP;\r
-                               al = M_POP;\r
-                               bh = TOS;\r
-                               bl = 0;\r
-                               q = 0;\r
-                               for( di=0; di<NBITS; di++ )\r
-                               {\r
-                                       if( !DULT(al,ah,bl,bh) )\r
-                                       {\r
-                                               sh = 0;\r
-                                               sl = al - bl;\r
-                                               if( al < bl ) sh = 1; /* Borrow */\r
-                                               sh = ah - bh - sh;\r
-                                               ah = sh;\r
-                                               al = sl;\r
-                                               q |= 1;\r
-                                       }\r
-                                       q = q << 1;\r
-                                       bl = (bl >> 1) | (bh << (NBITS-1));\r
-                                       bh = bh >> 1;\r
-                               }\r
-                               if( !DULT(al,ah,bl,bh) )\r
-                               {\r
-                               \r
-                                       al = al - bl;\r
-                                       q |= 1;\r
-                               }\r
-                               M_PUSH( al );  /* rem */\r
-                               TOS = q;\r
-                       }\r
-                       endcase;\r
-\r
-/* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */\r
-               case ID_D_MUSMOD:  /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r
-                       {\r
-                               register ucell_t ah,am,al,ql,qh,di;\r
-#define bdiv ((ucell_t)TOS)\r
-                               ah = 0;\r
-                               am = M_POP;\r
-                               al = M_POP;\r
-                               qh = ql = 0;\r
-                               for( di=0; di<2*NBITS; di++ )\r
-                               {\r
-                                       if( bdiv <= ah )\r
-                                       {\r
-                                               ah = ah - bdiv;\r
-                                               ql |= 1;\r
-                                       }\r
-                                       qh = (qh << 1) | (ql >> (NBITS-1));\r
-                                       ql = ql << 1;\r
-                                       ah = (ah << 1) | (am >> (NBITS-1));\r
-                                       am = (am << 1) | (al >> (NBITS-1));\r
-                                       al = al << 1;\r
-DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));\r
-                               }\r
-                               if( bdiv <= ah )\r
-                               {\r
-                                       ah = ah - bdiv;\r
-                                       ql |= 1;\r
-                               }\r
-                               M_PUSH( ah ); /* rem */\r
-                               M_PUSH( ql );\r
-                               TOS = qh;\r
-#undef bdiv\r
-                       }\r
-                       endcase;\r
-\r
-#ifndef PF_NO_SHELL\r
-               case ID_DEFER:\r
-                       ffDefer( );\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_DEFER_P:\r
-                       endcase;\r
-\r
-               case ID_DEPTH:\r
-                       PUSH_TOS;\r
-                       TOS = gCurrentTask->td_StackBase - STKPTR;\r
-                       endcase;\r
-                       \r
-               case ID_DIVIDE:     BINARY_OP( / ); endcase;\r
-                       \r
-               case ID_DOT:\r
-                       ffDot( TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_DOTS:\r
-                       M_DOTS;\r
-                       endcase;\r
-                       \r
-               case ID_DROP:  M_DROP; endcase;\r
-                       \r
-               case ID_DUMP:\r
-                       Scratch = M_POP;\r
-                       DumpMemory( (char *) Scratch, TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_DUP:   M_DUP; endcase;\r
-               \r
-               case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */\r
-                       M_R_PUSH( TOS );\r
-                       M_R_PUSH( M_POP );\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_EOL:    /* ( -- end_of_line_char ) */\r
-                       PUSH_TOS;\r
-                       TOS = (cell_t) '\n';\r
-                       endcase;\r
-                       \r
-               case ID_ERRORQ_P:  /* ( flag num -- , quit if flag true ) */\r
-                       Scratch = TOS;\r
-                       M_DROP;\r
-                       if(TOS)\r
-                       {\r
-                               M_THROW(Scratch);\r
-                       }\r
-                       else\r
-                       {\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-                       \r
-               case ID_EMIT_P:\r
-                       EMIT( (char) TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_EXECUTE:\r
-/* Save IP on return stack like a JSR. */\r
-                       M_R_PUSH( InsPtr );\r
-#ifdef PF_SUPPORT_TRACE\r
-/* Bump level for trace. */\r
-                       Level++;\r
-#endif\r
-                       if( IsTokenPrimitive( TOS ) )\r
-                       {\r
-                               WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS);   /* Build a fake secondary and execute it. */\r
-                               InsPtr = &FakeSecondary[0];\r
-                       }\r
-                       else\r
-                       {\r
-                               InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);\r
-                       }\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_FETCH:\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-                       if( IN_DICS( TOS ) )\r
-                       {\r
-                               TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);\r
-                       }\r
-                       else\r
-                       {\r
-                               TOS = *((cell_t *)TOS);\r
-                       }\r
-#else\r
-                       TOS = *((cell_t *)TOS);\r
-#endif\r
-                       endcase;\r
-               \r
-               case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */\r
-/* Build NUL terminated name string. */\r
-                       Scratch = M_POP; /* u */\r
-                       Temp = M_POP;    /* caddr */\r
-                       if( Scratch < TIB_SIZE-2 )\r
-                       {\r
-                               const char *famText = pfSelectFileModeCreate( TOS );\r
-                               pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r
-                               gScratch[Scratch] = '\0';\r
-                               DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));\r
-                               FileID = sdOpenFile( gScratch, famText );\r
-                               TOS = ( FileID == NULL ) ? -1 : 0 ;\r
-                               M_PUSH( (cell_t) FileID );\r
-                       }\r
-                       else\r
-                       {\r
-                               ERR("Filename too large for name buffer.\n");\r
-                               M_PUSH( 0 );\r
-                               TOS = -2;\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_FILE_DELETE: /* ( c-addr u -- ior ) */\r
-/* Build NUL terminated name string. */\r
-                       Temp = M_POP;    /* caddr */\r
-                       if( TOS < TIB_SIZE-2 )\r
-                       {\r
-                               pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );\r
-                               gScratch[TOS] = '\0';\r
-                               DBUG(("Delete file = %s\n", gScratch ));\r
-                               TOS = sdDeleteFile( gScratch );\r
-                       }\r
-                       else\r
-                       {\r
-                               ERR("Filename too large for name buffer.\n");\r
-                               TOS = -2;\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r
-/* Build NUL terminated name string. */\r
-                       Scratch = M_POP; /* u */\r
-                       Temp = M_POP;    /* caddr */\r
-                       if( Scratch < TIB_SIZE-2 )\r
-                       {\r
-                               const char *famText = pfSelectFileModeOpen( TOS );\r
-                               pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r
-                               gScratch[Scratch] = '\0';\r
-                               DBUG(("Open file = %s\n", gScratch ));\r
-                               FileID = sdOpenFile( gScratch, famText );\r
-\r
-                               TOS = ( FileID == NULL ) ? -1 : 0 ;\r
-                               M_PUSH( (cell_t) FileID );\r
-                       }\r
-                       else\r
-                       {\r
-                               ERR("Filename too large for name buffer.\n");\r
-                               M_PUSH( 0 );\r
-                               TOS = -2;\r
-                       }\r
-                       endcase;\r
-                       \r
-               case ID_FILE_CLOSE: /* ( fid -- ior ) */\r
-                       TOS = sdCloseFile( (FileStream *) TOS );\r
-                       endcase;\r
-                               \r
-               case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */\r
-                       FileID = (FileStream *) TOS;\r
-                       Scratch = M_POP;\r
-                       CharPtr = (char *) M_POP;\r
-                       Temp = sdReadFile( CharPtr, 1, Scratch, FileID );\r
-                       M_PUSH(Temp);\r
-                       TOS = 0;\r
-                       endcase;\r
-                               \r
-               case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r
-/* Determine file size by seeking to end and returning position. */\r
-                       FileID = (FileStream *) TOS;\r
-                       {\r
-                               off_t endposition, offsetHi;\r
-                               off_t original = sdTellFile( FileID );\r
-                               sdSeekFile( FileID, 0, PF_SEEK_END );\r
-                               endposition = sdTellFile( FileID );\r
-                               M_PUSH(endposition);\r
-                               /* Just use a 0 if they are the same size. */\r
-                               offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ;\r
-                               M_PUSH(offsetHi);\r
-                               sdSeekFile( FileID, original, PF_SEEK_SET );\r
-                               TOS = (original < 0) ? -4 : 0 ; /* !!! err num */\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r
-                       FileID = (FileStream *) TOS;\r
-                       Scratch = M_POP;\r
-                       CharPtr = (char *) M_POP;\r
-                       Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );\r
-                       TOS = (Temp != Scratch) ? -3 : 0;\r
-                       endcase;\r
-\r
-               case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */                                \r
-                       {\r
-                               off_t offset;\r
-                               FileID = (FileStream *) TOS;\r
-                               offset = M_POP;\r
-                               /* Avoid compiler warnings on Mac. */\r
-                               offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;\r
-                               offset += M_POP;\r
-                               TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_FILE_POSITION: /* ( fid -- ud ior ) */\r
-                       {\r
-                               off_t position;\r
-                               off_t offsetHi;\r
-                               FileID = (FileStream *) TOS;\r
-                               position = sdTellFile( FileID );\r
-                               M_PUSH(position);\r
-                               /* Just use a 0 if they are the same size. */\r
-                               offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;\r
-                               M_PUSH(offsetHi);\r
-                               TOS = (position < 0) ? -4 : 0 ; /* !!! err num */\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_FILE_RO: /* (  -- fam ) */\r
-                       PUSH_TOS;\r
-                       TOS = PF_FAM_READ_ONLY;\r
-                       endcase;\r
-                               \r
-               case ID_FILE_RW: /* ( -- fam ) */\r
-                       PUSH_TOS;\r
-                       TOS = PF_FAM_READ_WRITE;\r
-                       endcase;\r
-\r
-               case ID_FILE_WO: /* ( -- fam ) */\r
-                       PUSH_TOS;\r
-                       TOS = PF_FAM_WRITE_ONLY;\r
-                       endcase;\r
-\r
-               case ID_FILE_BIN: /* ( -- fam ) */\r
-                       TOS = TOS | PF_FAM_BINARY_FLAG;\r
-                       endcase;\r
-                               \r
-               case ID_FILL: /* ( caddr num charval -- ) */\r
-                       {\r
-                               register char *DstPtr;\r
-                               Temp = M_POP;    /* num */\r
-                               DstPtr = (char *) M_POP; /* dst */\r
-                               for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )\r
-                               {\r
-                                       *DstPtr++ = (char) TOS;\r
-                               }\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_FIND:  /* ( $addr -- $addr 0 | xt +-1 ) */\r
-                       TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );\r
-                       M_PUSH( Temp );\r
-                       endcase;\r
-                       \r
-               case ID_FINDNFA:\r
-                       TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r
-                       M_PUSH( (cell_t) Temp );\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_FLUSHEMIT:\r
-                       sdTerminalFlush();\r
-                       endcase;\r
-                       \r
-/* Validate memory before freeing. Clobber validator and first word. */\r
-               case ID_FREE:   /* ( addr -- result ) */\r
-                       if( TOS == 0 )\r
-                       {\r
-                               ERR("FREE passed NULL!\n");\r
-                               TOS = -2; /* FIXME error code */\r
-                       }\r
-                       else\r
-                       {\r
-                               CellPtr = (cell_t *) TOS;\r
-                               CellPtr--;\r
-                               if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))\r
-                               {\r
-                                       TOS = -2; /* FIXME error code */\r
-                               }\r
-                               else\r
-                               {\r
-                                       CellPtr[0] = 0xDeadBeef;\r
-                                       pfFreeMem((char *)CellPtr);\r
-                                       TOS = 0;\r
-                               }\r
-                       }\r
-                       endcase;\r
-                       \r
-#include "pfinnrfp.h"\r
-\r
-               case ID_HERE:\r
-                       PUSH_TOS;\r
-                       TOS = (cell_t)CODE_HERE;\r
-                       endcase;\r
-               \r
-               case ID_NUMBERQ_P:   /* ( addr -- 0 | n 1 ) */\r
-/* Convert using number converter in 'C'.\r
-** Only supports single precision for bootstrap.\r
-*/\r
-                       TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );\r
-                       if( TOS == NUM_TYPE_SINGLE)\r
-                       {\r
-                               M_PUSH( Temp );   /* Push single number */\r
-                       }\r
-                       endcase;\r
-                       \r
-               case ID_I:  /* ( -- i , DO LOOP index ) */\r
-                       PUSH_TOS;\r
-                       TOS = M_R_PICK(1);\r
-                       endcase;\r
-\r
-#ifndef PF_NO_SHELL\r
-               case ID_INCLUDE_FILE:\r
-                       FileID = (FileStream *) TOS;\r
-                       M_DROP;    /* Drop now so that INCLUDE has a clean stack. */\r
-                       SAVE_REGISTERS;\r
-                       Scratch = ffIncludeFile( FileID );\r
-                       LOAD_REGISTERS;\r
-                       if( Scratch ) M_THROW(Scratch)\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_INTERPRET:\r
-                       SAVE_REGISTERS;\r
-                       Scratch = ffInterpret();\r
-                       LOAD_REGISTERS;\r
-                       if( Scratch ) M_THROW(Scratch)\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_J:  /* ( -- j , second DO LOOP index ) */\r
-                       PUSH_TOS;\r
-                       TOS = M_R_PICK(3);\r
-                       endcase;\r
-\r
-               case ID_KEY:\r
-                       PUSH_TOS;\r
-                       TOS = ioKey();\r
-                       endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_LITERAL:\r
-                       ffLiteral( TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-#endif /* !PF_NO_SHELL */\r
-\r
-               case ID_LITERAL_P:\r
-                       DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r
-                       PUSH_TOS;\r
-                       TOS = READ_CELL_DIC(InsPtr++);\r
-                       endcase;\r
-       \r
-#ifndef PF_NO_SHELL\r
-               case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;\r
-#endif /* !PF_NO_SHELL */\r
-\r
-               case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */\r
-                       TOS = *(LocalsPtr - TOS);\r
-                       endcase;\r
-\r
-#define LOCAL_FETCH_N(num) \\r
-               case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \\r
-                       PUSH_TOS; \\r
-                       TOS = *(LocalsPtr -(num)); \\r
-                       endcase;\r
-\r
-               LOCAL_FETCH_N(1);\r
-               LOCAL_FETCH_N(2);\r
-               LOCAL_FETCH_N(3);\r
-               LOCAL_FETCH_N(4);\r
-               LOCAL_FETCH_N(5);\r
-               LOCAL_FETCH_N(6);\r
-               LOCAL_FETCH_N(7);\r
-               LOCAL_FETCH_N(8);\r
-               \r
-               case ID_LOCAL_STORE:  /* ( n i <local> -- , store n in local ) */\r
-                       *(LocalsPtr - TOS) = M_POP;\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-#define LOCAL_STORE_N(num) \\r
-               case ID_LOCAL_STORE_##num:  /* ( n <local> -- , store n in local ) */ \\r
-                       *(LocalsPtr - (num)) = TOS; \\r
-                       M_DROP; \\r
-                       endcase;\r
-\r
-               LOCAL_STORE_N(1);\r
-               LOCAL_STORE_N(2);\r
-               LOCAL_STORE_N(3);\r
-               LOCAL_STORE_N(4);\r
-               LOCAL_STORE_N(5);\r
-               LOCAL_STORE_N(6);\r
-               LOCAL_STORE_N(7);\r
-               LOCAL_STORE_N(8);\r
-               \r
-               case ID_LOCAL_PLUSSTORE:  /* ( n i <local> -- , add n to local ) */\r
-                       *(LocalsPtr - TOS) += M_POP;\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r
-               /* create local stack frame */\r
-                       {\r
-                               cell_t i = TOS;\r
-                               cell_t *lp;\r
-                               DBUG(("LocalEntry: n = %d\n", TOS));\r
-                               /* End of locals. Create stack frame */\r
-                               DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r
-                                       TORPTR, LocalsPtr));\r
-                               M_R_PUSH(LocalsPtr);\r
-                               LocalsPtr = TORPTR;\r
-                               TORPTR -= TOS;\r
-                               DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",\r
-                                       TORPTR, LocalsPtr));\r
-                               lp = TORPTR;\r
-                               while(i-- > 0)\r
-                               {\r
-                                       *lp++ = M_POP;    /* Load local vars from stack */\r
-                               }\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_LOCAL_EXIT: /* cleanup up local stack frame */\r
-                       DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r
-                               TORPTR, LocalsPtr));\r
-                       TORPTR = LocalsPtr;\r
-                       LocalsPtr = (cell_t *) M_R_POP;\r
-                       DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r
-                               TORPTR, LocalsPtr));\r
-                       endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_LOADSYS:\r
-                       MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;\r
-                       FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");\r
-                       if( FileID )\r
-                       {\r
-                               SAVE_REGISTERS;\r
-                               Scratch = ffIncludeFile( FileID ); /* Also closes the file. */\r
-                               LOAD_REGISTERS;\r
-                               if( Scratch ) M_THROW(Scratch);\r
-                       }\r
-                       else\r
-                       {\r
-                                ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");\r
-                       }\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-               case ID_LEAVE_P: /* ( R: index limit --  ) */\r
-                       M_R_DROP;\r
-                       M_R_DROP;\r
-                       M_BRANCH;\r
-                       endcase;\r
-\r
-               case ID_LOOP_P: /* ( R: index limit -- | index limit ) */\r
-                       Temp = M_R_POP; /* limit */\r
-                       Scratch = M_R_POP + 1; /* index */\r
-                       if( Scratch == Temp )\r
-                       {\r
-                               InsPtr++;   /* skip branch offset, exit loop */\r
-                       }\r
-                       else\r
-                       {\r
-/* Push index and limit back to R */\r
-                               M_R_PUSH( Scratch );\r
-                               M_R_PUSH( Temp );\r
-/* Branch back to just after (DO) */\r
-                               M_BRANCH;\r
-                       }\r
-                       endcase;\r
-                               \r
-               case ID_LSHIFT:     BINARY_OP( << ); endcase;\r
-               \r
-               case ID_MAX:\r
-                       Scratch = M_POP;\r
-                       TOS = ( TOS > Scratch ) ? TOS : Scratch ;\r
-                       endcase;\r
-                       \r
-               case ID_MIN:\r
-                       Scratch = M_POP;\r
-                       TOS = ( TOS < Scratch ) ? TOS : Scratch ;\r
-                       endcase;\r
-                       \r
-               case ID_MINUS:     BINARY_OP( - ); endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_NAME_TO_TOKEN:\r
-                       TOS = (cell_t) NameToToken((ForthString *)TOS);\r
-                       endcase;\r
-                       \r
-               case ID_NAME_TO_PREVIOUS:\r
-                       TOS = (cell_t) NameToPrevious((ForthString *)TOS);\r
-                       endcase;\r
-#endif\r
-                       \r
-               case ID_NOOP:\r
-                       endcase;\r
-                       \r
-               case ID_OR:     BINARY_OP( | ); endcase;\r
-               \r
-               case ID_OVER:\r
-                       PUSH_TOS;\r
-                       TOS = M_STACK(1);\r
-                       endcase;\r
-                       \r
-               case ID_PICK: /* ( ... n -- sp(n) ) */\r
-                       TOS = M_STACK(TOS);\r
-                       endcase;\r
-\r
-               case ID_PLUS:     BINARY_OP( + ); endcase;\r
-               \r
-               case ID_PLUS_STORE:   /* ( n addr -- , add n to *addr ) */\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-                       if( IN_DICS( TOS ) )\r
-                       {\r
-                               Scratch = READ_CELL_DIC((cell_t *)TOS);\r
-                               Scratch += M_POP;\r
-                               WRITE_CELL_DIC((cell_t *)TOS,Scratch);\r
-                       }\r
-                       else\r
-                       {\r
-                               *((cell_t *)TOS) += M_POP;\r
-                       }\r
-#else\r
-                       *((cell_t *)TOS) += M_POP;\r
-#endif\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r
-                       {\r
-                               ucell_t OldIndex, NewIndex, Limit;\r
-\r
-                               Limit = M_R_POP;\r
-                               OldIndex = M_R_POP;\r
-                               NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */\r
-/* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
-                               if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
-                                   ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
-                               {\r
-                                       InsPtr++;   /* skip branch offset, exit loop */\r
-                               }\r
-                               else\r
-                               {\r
-/* Push index and limit back to R */\r
-                                       M_R_PUSH( NewIndex );\r
-                                       M_R_PUSH( Limit );\r
-/* Branch back to just after (DO) */\r
-                                       M_BRANCH;\r
-                               }\r
-                               M_DROP;\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */\r
-                       Scratch = M_POP;  /* limit */\r
-                       if( Scratch == TOS )\r
-                       {\r
-/* Branch to just after (LOOP) */\r
-                               M_BRANCH;\r
-                       }\r
-                       else\r
-                       {\r
-                               M_R_PUSH( TOS );\r
-                               M_R_PUSH( Scratch );\r
-                               InsPtr++;   /* skip branch offset, enter loop */\r
-                       }\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_QDUP:     if( TOS ) M_DUP; endcase;\r
-\r
-               case ID_QTERMINAL:  /* WARNING: Typically not fully implemented! */\r
-                       PUSH_TOS;\r
-                       TOS = sdQueryTerminal();\r
-                       endcase;\r
-               \r
-               case ID_QUIT_P: /* Stop inner interpreter, go back to user. */\r
-#ifdef PF_SUPPORT_TRACE\r
-                       Level = 0;\r
-#endif\r
-                       M_THROW(THROW_QUIT);\r
-                       endcase;\r
-                       \r
-               case ID_R_DROP:\r
-                       M_R_DROP;\r
-                       endcase;\r
-\r
-               case ID_R_FETCH:\r
-                       PUSH_TOS;\r
-                       TOS = (*(TORPTR));\r
-                       endcase;\r
-               \r
-               case ID_R_FROM:\r
-                       PUSH_TOS;\r
-                       TOS = M_R_POP;\r
-                       endcase;\r
-                       \r
-               case ID_REFILL:\r
-                       PUSH_TOS;\r
-                       TOS = (ffRefill() > 0) ? FTRUE : FFALSE;\r
-                       endcase;\r
-                       \r
-/* Resize memory allocated by ALLOCATE. */\r
-               case ID_RESIZE:  /* ( addr1 u -- addr2 result ) */\r
-                       {\r
-                               cell_t *Addr1 = (cell_t *) M_POP;\r
-                               /* Point to validator below users address. */\r
-                               cell_t *FreePtr = Addr1 - 1;\r
-                               if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))\r
-                               {\r
-                                       /* 090218 - Fixed bug, was returning zero. */\r
-                                       M_PUSH( Addr1 );\r
-                                       TOS = -3;\r
-                               }\r
-                               else\r
-                               {\r
-                                       /* Try to allocate. */\r
-                                       CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );\r
-                                       if( CellPtr )\r
-                                       {\r
-                                               /* Copy memory including validation. */\r
-                                               pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );\r
-                                               *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);\r
-                                               /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */\r
-                                               /* Increment past validator to user address. */\r
-                                   M_PUSH( (cell_t) (CellPtr + 1) );\r
-                                               TOS = 0; /* Result code. */\r
-                                               /* Mark old cell as dead so we can't free it twice. */\r
-                                               FreePtr[0] = 0xDeadBeef;\r
-                                               pfFreeMem((char *) FreePtr);\r
-                                       }\r
-                                       else\r
-                                       {\r
-                                               /* 090218 - Fixed bug, was returning zero. */\r
-                                               M_PUSH( Addr1 );\r
-                                               TOS = -4;  /* FIXME Fix error code. */\r
-                                       }\r
-                               }\r
-                       }\r
-                       endcase;\r
-                               \r
-/*\r
-** RP@ and RP! are called secondaries so we must\r
-** account for the return address pushed before calling.\r
-*/\r
-               case ID_RP_FETCH:    /* ( -- rp , address of top of return stack ) */\r
-                       PUSH_TOS;\r
-                       TOS = (cell_t)TORPTR;  /* value before calling RP@ */\r
-                       endcase;\r
-                       \r
-               case ID_RP_STORE:    /* ( rp -- , address of top of return stack ) */\r
-                       TORPTR = (cell_t *) TOS;\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r
-                       {\r
-                               cell_t ri;\r
-                               cell_t *srcPtr, *dstPtr;\r
-                               Scratch = M_STACK(TOS);\r
-                               srcPtr = &M_STACK(TOS-1);\r
-                               dstPtr = &M_STACK(TOS);\r
-                               for( ri=0; ri<TOS; ri++ )\r
-                               {\r
-                                       *dstPtr-- = *srcPtr--;\r
-                               }\r
-                               TOS = Scratch;\r
-                               STKPTR++;\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_ROT:  /* ( a b c -- b c a ) */\r
-                       Scratch = M_POP;    /* b */\r
-                       Temp = M_POP;       /* a */\r
-                       M_PUSH( Scratch );  /* b */\r
-                       PUSH_TOS;           /* c */\r
-                       TOS = Temp;         /* a */\r
-                       endcase;\r
-\r
-/* Logical right shift */\r
-               case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> TOS; } endcase;   \r
-               \r
-#ifndef PF_NO_SHELL\r
-               case ID_SAVE_FORTH_P:   /* ( $name Entry NameSize CodeSize -- err ) */\r
-                       {\r
-                               cell_t NameSize, CodeSize, EntryPoint;\r
-                               CodeSize = TOS;\r
-                               NameSize = M_POP;\r
-                               EntryPoint = M_POP;\r
-                               ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );\r
-                               TOS =  ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r
-                       }\r
-                       endcase;\r
-#endif\r
-\r
-/* Source     Stack\r
-** EVALUATE    >IN  SourceID=(-1)  1111\r
-** keyboard    >IN  SourceID=(0)   2222\r
-** file        >IN  lineNumber filePos  SourceID=(fileID)\r
-*/\r
-               case ID_SAVE_INPUT:  /* FIXME - finish */\r
-                       {\r
-                       }\r
-                       endcase;\r
-\r
-               case ID_SP_FETCH:    /* ( -- sp , address of top of stack, sorta ) */\r
-                       PUSH_TOS;\r
-                       TOS = (cell_t)STKPTR;\r
-                       endcase;\r
-                       \r
-               case ID_SP_STORE:    /* ( sp -- , address of top of stack, sorta ) */\r
-                       STKPTR = (cell_t *) TOS;\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_STORE: /* ( n addr -- , write n to addr ) */\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-                       if( IN_DICS( TOS ) )\r
-                       {\r
-                               WRITE_CELL_DIC((cell_t *)TOS,M_POP);\r
-                       }\r
-                       else\r
-                       {\r
-                               *((cell_t *)TOS) = M_POP;\r
-                       }\r
-#else\r
-                       *((cell_t *)TOS) = M_POP;\r
-#endif\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */\r
-                       Scratch = M_POP; /* cnt */\r
-                       Temp = M_POP;    /* addr */\r
-                       TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
-                       M_PUSH((cell_t) CharPtr);\r
-                       endcase;\r
-                       \r
-#ifndef PF_NO_SHELL\r
-               case ID_SEMICOLON:\r
-                       SAVE_REGISTERS;\r
-                       Scratch = ffSemiColon();\r
-                       LOAD_REGISTERS;\r
-                       if( Scratch ) M_THROW( Scratch );\r
-                       endcase;\r
-#endif /* !PF_NO_SHELL */\r
-                       \r
-               case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */\r
-                       Scratch = M_POP; /* cnt */\r
-                       Temp = M_POP;    /* addr */\r
-                       TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
-                       M_PUSH((cell_t) CharPtr);\r
-                       endcase;\r
-\r
-               case ID_SOURCE:  /* ( -- c-addr num ) */\r
-                       PUSH_TOS;\r
-                       M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );\r
-                       TOS = (cell_t) gCurrentTask->td_SourceNum;\r
-                       endcase;\r
-                       \r
-               case ID_SOURCE_SET: /* ( c-addr num -- ) */\r
-                       gCurrentTask->td_SourcePtr = (char *) M_POP;\r
-                       gCurrentTask->td_SourceNum = TOS;\r
-                       M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_SOURCE_ID:\r
-                       PUSH_TOS;\r
-                       TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;\r
-                       endcase;\r
-                       \r
-               case ID_SOURCE_ID_POP:\r
-                       PUSH_TOS;\r
-                       TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;\r
-                       endcase;\r
-                       \r
-               case ID_SOURCE_ID_PUSH:  /* ( source-id -- ) */\r
-                       TOS = (cell_t)ffConvertSourceIDToStream( TOS );\r
-                       Scratch = ffPushInputStream((FileStream *) TOS );\r
-                       if( Scratch )\r
-                       {\r
-                               M_THROW(Scratch);\r
-                       }\r
-                       else M_DROP;\r
-                       endcase;\r
-                       \r
-               case ID_SWAP:\r
-                       Scratch = TOS;\r
-                       TOS = *STKPTR;\r
-                       *STKPTR = Scratch;\r
-                       endcase;\r
-                       \r
-               case ID_TEST1:\r
-                       PUSH_TOS;\r
-                       M_PUSH( 0x11 );\r
-                       M_PUSH( 0x22 );\r
-                       TOS = 0x33;\r
-                       endcase;\r
-\r
-               case ID_TEST2:\r
-                       endcase;\r
-\r
-               case ID_THROW:  /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */\r
-                       if(TOS)\r
-                       {\r
-                               M_THROW(TOS);\r
-                       }\r
-                       else M_DROP;\r
-                       endcase;\r
-\r
-#ifndef PF_NO_SHELL\r
-               case ID_TICK:\r
-                       PUSH_TOS;\r
-                       CharPtr = (char *) ffWord( (char) ' ' );\r
-                       TOS = ffFind( CharPtr, (ExecToken *) &Temp );\r
-                       if( TOS == 0 )\r
-                       {\r
-                               ERR("' could not find ");\r
-                               ioType( (char *) CharPtr+1, *CharPtr );\r
-                               M_THROW(-13);\r
-                       }\r
-                       else\r
-                       {\r
-                               TOS = Temp;\r
-                       }\r
-                       endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-                       \r
-               case ID_TIMES: BINARY_OP( * ); endcase;\r
-                       \r
-               case ID_TYPE:\r
-                       Scratch = M_POP; /* addr */\r
-                       ioType( (char *) Scratch, TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_TO_R:\r
-                       M_R_PUSH( TOS );\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_VAR_BASE: DO_VAR(gVarBase); endcase;\r
-               case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;\r
-               case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;\r
-               case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;\r
-               case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;\r
-               case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r
-               case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r
-               case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r
-               case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;\r
-               case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r
-               case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r
-               case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r
-               case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;\r
-               case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;\r
-               case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;\r
-               case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;\r
-               case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r
-\r
-               case ID_WORD:\r
-                       TOS = (cell_t) ffWord( (char) TOS );\r
-                       endcase;\r
-\r
-               case ID_WORD_FETCH: /* ( waddr -- w ) */\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-                       if( IN_DICS( TOS ) )\r
-                       {\r
-                               TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);\r
-                       }\r
-                       else\r
-                       {\r
-                               TOS = *((uint16_t *)TOS);\r
-                       }\r
-#else\r
-                       TOS = *((uint16_t *)TOS);\r
-#endif\r
-                       endcase;\r
-\r
-               case ID_WORD_STORE: /* ( w waddr -- ) */\r
-                       \r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-                       if( IN_DICS( TOS ) )\r
-                       {\r
-                               WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);\r
-                       }\r
-                       else\r
-                       {\r
-                               *((uint16_t *)TOS) = (uint16_t) M_POP;\r
-                       }\r
-#else\r
-                       *((uint16_t *)TOS) = (uint16_t) M_POP;\r
-#endif\r
-                       M_DROP;\r
-                       endcase;\r
-\r
-               case ID_XOR: BINARY_OP( ^ ); endcase;\r
-                               \r
-                               \r
-/* Branch is followed by an offset relative to address of offset. */\r
-               case ID_ZERO_BRANCH:\r
-DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));\r
-                       if( TOS == 0 )\r
-                       {\r
-                               M_BRANCH;\r
-                       }\r
-                       else\r
-                       {\r
-                               InsPtr++;      /* skip over offset */\r
-                       }\r
-                       M_DROP;\r
-DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));\r
-                       endcase;\r
-                       \r
-               default:\r
-                       ERR("pfCatch: Unrecognised token = 0x");\r
-                       ffDotHex(Token);\r
-                       ERR(" at 0x");\r
-                       ffDotHex((cell_t) InsPtr);\r
-                       EMIT_CR;\r
-                       InsPtr = 0;\r
-                       endcase;\r
-               }\r
-               \r
-               if(InsPtr) Token = READ_CELL_DIC(InsPtr++);   /* Traverse to next token in secondary. */\r
-               \r
-#ifdef PF_DEBUG\r
-               M_DOTS;\r
-#endif\r
-\r
-#if 0\r
-               if( _CrtCheckMemory() == 0 )\r
-               {\r
-                       ERR("_CrtCheckMemory abort: InsPtr = 0x");\r
-                       ffDotHex((int)InsPtr);\r
-                       ERR("\n");\r
-               }\r
-#endif\r
-\r
-       } while( (InitialReturnStack - TORPTR) > 0 );\r
-\r
-       SAVE_REGISTERS;\r
-       \r
-       return ExceptionReturnCode;\r
-}\r
+/* @(#) pf_inner.c 98/03/16 1.7 */
+/***************************************************************
+** Inner Interpreter for Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+**
+** 940502 PLB Creation.
+** 940505 PLB More macros.
+** 940509 PLB Moved all stack stuff into pfCatch.
+** 941014 PLB Converted to flat secondary strusture.
+** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH,
+**             and ID_HERE for armcc
+** 941130 PLB Made w@ unsigned
+**
+***************************************************************/
+
+#include <sys/types.h>
+
+#include "pf_all.h"
+
+#if defined(WIN32) && !defined(__MINGW32__)
+#include <crtdbg.h>
+#endif
+
+#define SYSTEM_LOAD_FILE "system.fth"
+
+/***************************************************************
+** Macros for data stack access.
+** TOS is cached in a register in pfCatch.
+***************************************************************/
+
+#define STKPTR   (DataStackPtr)
+#define M_POP    (*(STKPTR++))
+#define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}
+#define M_STACK(n) (STKPTR[n])
+
+#define TOS      (TopOfStack)
+#define PUSH_TOS M_PUSH(TOS)
+#define M_DUP    PUSH_TOS;
+#define M_DROP   { TOS = M_POP; }
+
+
+/***************************************************************
+** Macros for Floating Point stack access.
+***************************************************************/
+#ifdef PF_SUPPORT_FP
+#define FP_STKPTR   (FloatStackPtr)
+#define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
+#define M_FP_POP    (*(FP_STKPTR++))
+#define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
+#define M_FP_STACK(n) (FP_STKPTR[n])
+
+#define FP_TOS      (fpTopOfStack)
+#define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
+#define M_FP_DUP    PUSH_FP_TOS;
+#define M_FP_DROP   { FP_TOS = M_FP_POP; }
+#endif
+
+/***************************************************************
+** Macros for return stack access.
+***************************************************************/
+
+#define TORPTR (ReturnStackPtr)
+#define M_R_DROP {TORPTR++;}
+#define M_R_POP (*(TORPTR++))
+#define M_R_PICK(n) (TORPTR[n])
+#define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}
+
+/***************************************************************
+** Misc Forth macros
+***************************************************************/
+
+#define M_BRANCH   { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }
+
+/* Cache top of data stack like in JForth. */
+#ifdef PF_SUPPORT_FP
+#define LOAD_REGISTERS \
+    { \
+        STKPTR = gCurrentTask->td_StackPtr; \
+        TOS = M_POP; \
+        FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
+        FP_TOS = M_FP_POP; \
+        TORPTR = gCurrentTask->td_ReturnPtr; \
+     }
+
+#define SAVE_REGISTERS \
+    { \
+        gCurrentTask->td_ReturnPtr = TORPTR; \
+        M_PUSH( TOS ); \
+        gCurrentTask->td_StackPtr = STKPTR; \
+        M_FP_PUSH( FP_TOS ); \
+        gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
+     }
+
+#else
+/* Cache top of data stack like in JForth. */
+#define LOAD_REGISTERS \
+    { \
+        STKPTR = gCurrentTask->td_StackPtr; \
+        TOS = M_POP; \
+        TORPTR = gCurrentTask->td_ReturnPtr; \
+     }
+
+#define SAVE_REGISTERS \
+    { \
+        gCurrentTask->td_ReturnPtr = TORPTR; \
+        M_PUSH( TOS ); \
+        gCurrentTask->td_StackPtr = STKPTR; \
+     }
+#endif
+
+#define M_DOTS \
+    SAVE_REGISTERS; \
+    ffDotS( ); \
+    LOAD_REGISTERS;
+
+#define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }
+
+#ifdef PF_SUPPORT_FP
+#define M_THROW(err) \
+    { \
+        ExceptionReturnCode = (ThrowCode)(err); \
+        TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
+        STKPTR = InitialDataStack; \
+        FP_STKPTR = InitialFloatStack; \
+    }
+#else
+#define M_THROW(err) \
+    { \
+        ExceptionReturnCode = (err); \
+        TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
+        STKPTR = InitialDataStack; \
+    }
+#endif
+
+/***************************************************************
+** Other macros
+***************************************************************/
+
+#define BINARY_OP( op ) { TOS = M_POP op TOS; }
+#define endcase break
+
+#if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
+    #define TRACENAMES /* no names */
+#else
+/* Display name of executing routine. */
+static void TraceNames( ExecToken Token, cell_t Level )
+{
+    char *DebugName;
+    cell_t i;
+
+    if( ffTokenToName( Token, &DebugName ) )
+    {
+        cell_t NumSpaces;
+        if( gCurrentTask->td_OUT > 0 ) EMIT_CR;
+        EMIT( '>' );
+        for( i=0; i<Level; i++ )
+        {
+            MSG( "  " );
+        }
+        TypeName( DebugName );
+/* Space out to column N then .S */
+        NumSpaces = 30 - gCurrentTask->td_OUT;
+        for( i=0; i < NumSpaces; i++ )
+        {
+            EMIT( ' ' );
+        }
+        ffDotS();
+/* No longer needed?        gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
+
+    }
+    else
+    {
+        MSG_NUM_H("Couldn't find Name for ", Token);
+    }
+}
+
+#define TRACENAMES \
+    if( (gVarTraceLevel > Level) ) \
+    { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
+#endif /* PF_NO_SHELL */
+
+/* Use local copy of CODE_BASE for speed. */
+#define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
+
+static const char *pfSelectFileModeCreate( int fam );
+static const char *pfSelectFileModeOpen( int fam );
+
+/**************************************************************/
+static const char *pfSelectFileModeCreate( int fam )
+{
+    const char *famText = NULL;
+    switch( fam )
+    {
+    case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
+        famText = PF_FAM_BIN_CREATE_WO;
+        break;
+    case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
+        famText = PF_FAM_BIN_CREATE_RW;
+        break;
+    case PF_FAM_WRITE_ONLY:
+        famText = PF_FAM_CREATE_WO;
+        break;
+    case PF_FAM_READ_WRITE:
+        famText = PF_FAM_CREATE_RW;
+        break;
+    default:
+        famText = "illegal";
+        break;
+    }
+    return famText;
+}
+
+/**************************************************************/
+static const char *pfSelectFileModeOpen( int fam )
+{
+    const char *famText = NULL;
+    switch( fam )
+    {
+    case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):
+        famText = PF_FAM_BIN_OPEN_RO;
+        break;
+    case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
+        famText = PF_FAM_BIN_CREATE_WO;
+        break;
+    case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
+        famText = PF_FAM_BIN_OPEN_RW;
+        break;
+    case PF_FAM_READ_ONLY:
+        famText = PF_FAM_OPEN_RO;
+        break;
+    case PF_FAM_WRITE_ONLY:
+        famText = PF_FAM_CREATE_WO;
+        break;
+    case PF_FAM_READ_WRITE:
+    default:
+        famText = PF_FAM_OPEN_RW;
+        break;
+    }
+    return famText;
+}
+
+/**************************************************************/
+int pfCatch( ExecToken XT )
+{
+    register cell_t  TopOfStack;    /* Cache for faster execution. */
+    register cell_t *DataStackPtr;
+    register cell_t *ReturnStackPtr;
+    register cell_t *InsPtr = NULL;
+    register cell_t  Token;
+    cell_t           Scratch;
+
+#ifdef PF_SUPPORT_FP
+    PF_FLOAT       fpTopOfStack;
+    PF_FLOAT      *FloatStackPtr;
+    PF_FLOAT       fpScratch;
+    PF_FLOAT       fpTemp;
+    PF_FLOAT      *InitialFloatStack;
+#endif
+#ifdef PF_SUPPORT_TRACE
+    cell_t Level = 0;
+#endif
+    cell_t        *LocalsPtr = NULL;
+    cell_t         Temp;
+    cell_t        *InitialReturnStack;
+    cell_t        *InitialDataStack;
+    cell_t         FakeSecondary[2];
+    char          *CharPtr;
+    cell_t        *CellPtr;
+    FileStream    *FileID;
+    uint8_t       *CodeBase = (uint8_t *) CODE_BASE;
+    ThrowCode      ExceptionReturnCode = 0;
+
+/* FIXME
+    gExecutionDepth += 1;
+    PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));
+*/
+
+/*
+** Initialize FakeSecondary this way to avoid having stuff in the data section,
+** which is not supported for some embedded system loaders.
+*/
+    FakeSecondary[0] = 0;
+    FakeSecondary[1] = ID_EXIT; /* For EXECUTE */
+
+/* Move data from task structure to registers for speed. */
+    LOAD_REGISTERS;
+
+/* Save initial stack depths for THROW */
+    InitialReturnStack = TORPTR;
+    InitialDataStack   = STKPTR ;
+#ifdef PF_SUPPORT_FP
+    InitialFloatStack  = FP_STKPTR;
+#endif
+
+    Token = XT;
+
+    do
+    {
+DBUG(("pfCatch: Token = 0x%x\n", Token ));
+
+/* --------------------------------------------------------------- */
+/* If secondary, thread down code tree until we hit a primitive. */
+        while( !IsTokenPrimitive( Token ) )
+        {
+#ifdef PF_SUPPORT_TRACE
+            if((gVarTraceFlags & TRACE_INNER) )
+            {
+                MSG("pfCatch: Secondary Token = 0x");
+                ffDotHex(Token);
+                MSG_NUM_H(", InsPtr = 0x", InsPtr);
+            }
+            TRACENAMES;
+#endif
+
+/* Save IP on return stack like a JSR. */
+            M_R_PUSH( InsPtr );
+
+/* Convert execution token to absolute address. */
+            InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );
+
+/* Fetch token at IP. */
+            Token = READ_CELL_DIC(InsPtr++);
+
+#ifdef PF_SUPPORT_TRACE
+/* Bump level for trace display */
+            Level++;
+#endif
+        }
+
+
+#ifdef PF_SUPPORT_TRACE
+        TRACENAMES;
+#endif
+
+/* Execute primitive Token. */
+        switch( Token )
+        {
+
+    /* Pop up a level in Forth inner interpreter.
+    ** Used to implement semicolon.
+    ** Put first in switch because ID_EXIT==0 */
+        case ID_EXIT:
+            InsPtr = ( cell_t *) M_R_POP;
+#ifdef PF_SUPPORT_TRACE
+            Level--;
+#endif
+            endcase;
+
+        case ID_1MINUS:  TOS--; endcase;
+
+        case ID_1PLUS:   TOS++; endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_2LITERAL:
+            ff2Literal( TOS, M_POP );
+            M_DROP;
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_2LITERAL_P:
+/* hi part stored first, put on top of stack */
+            PUSH_TOS;
+            TOS = READ_CELL_DIC(InsPtr++);
+            M_PUSH(READ_CELL_DIC(InsPtr++));
+            endcase;
+
+        case ID_2MINUS:  TOS -= 2; endcase;
+
+        case ID_2PLUS:   TOS += 2; endcase;
+
+
+        case ID_2OVER:  /* ( a b c d -- a b c d a b ) */
+            PUSH_TOS;
+            Scratch = M_STACK(3);
+            M_PUSH(Scratch);
+            TOS = M_STACK(3);
+            endcase;
+
+        case ID_2SWAP:  /* ( a b c d -- c d a b ) */
+            Scratch = M_STACK(0);    /* c */
+            M_STACK(0) = M_STACK(2); /* a */
+            M_STACK(2) = Scratch;    /* c */
+            Scratch = TOS;           /* d */
+            TOS = M_STACK(1);        /* b */
+            M_STACK(1) = Scratch;    /* d */
+            endcase;
+
+        case ID_2DUP:   /* ( a b -- a b a b ) */
+            PUSH_TOS;
+            Scratch = M_STACK(1);
+            M_PUSH(Scratch);
+            endcase;
+
+        case ID_2_R_FETCH:
+            PUSH_TOS;
+            M_PUSH( (*(TORPTR+1)) );
+            TOS = (*(TORPTR));
+            endcase;
+
+        case ID_2_R_FROM:
+            PUSH_TOS;
+            TOS = M_R_POP;
+            M_PUSH( M_R_POP );
+            endcase;
+
+        case ID_2_TO_R:
+            M_R_PUSH( M_POP );
+            M_R_PUSH( TOS );
+            M_DROP;
+            endcase;
+
+        case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */
+            CharPtr = (char *) M_POP;
+            TOS = ioAccept( CharPtr, TOS );
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_ALITERAL:
+            ffALiteral( ABS_TO_CODEREL(TOS) );
+            M_DROP;
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_ALITERAL_P:
+            PUSH_TOS;
+            TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );
+            endcase;
+
+/* Allocate some extra and put validation identifier at base */
+#define PF_MEMORY_VALIDATOR  (0xA81B4D69)
+        case ID_ALLOCATE:
+            /* Allocate at least one cell's worth because we clobber first cell. */
+            if ( TOS < sizeof(cell_t) )
+            {
+                Temp = sizeof(cell_t);
+            }
+            else
+            {
+                Temp = TOS;
+            }
+            /* Allocate extra cells worth because we store validation info. */
+            CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );
+            if( CellPtr )
+            {
+/* This was broken into two steps because different compilers incremented
+** CellPtr before or after the XOR step. */
+                Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;
+                *CellPtr++ = Temp;
+                M_PUSH( (cell_t) CellPtr );
+                TOS = 0;
+            }
+            else
+            {
+                M_PUSH( 0 );
+                TOS = -1;  /* FIXME Fix error code. */
+            }
+            endcase;
+
+        case ID_AND:     BINARY_OP( & ); endcase;
+
+        case ID_ARSHIFT:     BINARY_OP( >> ); endcase;  /* Arithmetic right shift */
+
+        case ID_BODY_OFFSET:
+            PUSH_TOS;
+            TOS = CREATE_BODY_OFFSET;
+            endcase;
+
+/* Branch is followed by an offset relative to address of offset. */
+        case ID_BRANCH:
+DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));
+            M_BRANCH;
+DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
+            endcase;
+
+        case ID_BYE:
+            M_THROW( THROW_BYE );
+            endcase;
+
+        case ID_BAIL:
+            MSG("Emergency exit.\n");
+            EXIT(1);
+            endcase;
+
+        case ID_CATCH:
+            Scratch = TOS;
+            TOS = M_POP;
+            SAVE_REGISTERS;
+            Scratch = pfCatch( Scratch );
+            LOAD_REGISTERS;
+            M_PUSH( TOS );
+            TOS = Scratch;
+            endcase;
+
+        case ID_CALL_C:
+            SAVE_REGISTERS;
+            Scratch = READ_CELL_DIC(InsPtr++);
+            CallUserFunction( Scratch & 0xFFFF,
+                (Scratch >> 31) & 1,
+                (Scratch >> 24) & 0x7F );
+            LOAD_REGISTERS;
+            endcase;
+
+        /* Support 32/64 bit operation. */
+        case ID_CELL:
+                M_PUSH( TOS );
+                TOS = sizeof(cell_t);
+                endcase;
+
+        case ID_CELLS:
+                TOS = TOS * sizeof(cell_t);
+                endcase;
+
+        case ID_CFETCH:   TOS = *((uint8_t *) TOS); endcase;
+
+        case ID_CMOVE: /* ( src dst n -- ) */
+            {
+                register char *DstPtr = (char *) M_POP; /* dst */
+                CharPtr = (char *) M_POP;    /* src */
+                for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
+                {
+                    *DstPtr++ = *CharPtr++;
+                }
+                M_DROP;
+            }
+            endcase;
+
+        case ID_CMOVE_UP: /* ( src dst n -- ) */
+            {
+                register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
+                CharPtr = ((char *) M_POP) + TOS;;    /* src */
+                for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
+                {
+                    *(--DstPtr) = *(--CharPtr);
+                }
+                M_DROP;
+            }
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_COLON:
+            SAVE_REGISTERS;
+            ffColon( );
+            LOAD_REGISTERS;
+            endcase;
+        case ID_COLON_P:  /* ( $name xt -- ) */
+            CreateDicEntry( TOS, (char *) M_POP, 0 );
+            M_DROP;
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_COMPARE:
+            {
+                const char *s1, *s2;
+                cell_t len1;
+                s2 = (const char *) M_POP;
+                len1 = M_POP;
+                s1 = (const char *) M_POP;
+                TOS = ffCompare( s1, len1, s2, TOS );
+            }
+            endcase;
+
+/* ( a b -- flag , Comparisons ) */
+        case ID_COMP_EQUAL:
+            TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_NOT_EQUAL:
+            TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_GREATERTHAN:
+            TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_LESSTHAN:
+            TOS = (  M_POP < TOS ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_U_GREATERTHAN:
+            TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_U_LESSTHAN:
+            TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_ZERO_EQUAL:
+            TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_ZERO_NOT_EQUAL:
+            TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
+            endcase;
+        case ID_COMP_ZERO_GREATERTHAN:
+            TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
+            endcase;
+        case ID_COMP_ZERO_LESSTHAN:
+            TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
+            endcase;
+
+        case ID_CR:
+            EMIT_CR;
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_CREATE:
+            SAVE_REGISTERS;
+            ffCreate();
+            LOAD_REGISTERS;
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_CREATE_P:
+            PUSH_TOS;
+/* Put address of body on stack.  Insptr points after code start. */
+            TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );
+            endcase;
+
+        case ID_CSTORE: /* ( c caddr -- ) */
+            *((uint8_t *) TOS) = (uint8_t) M_POP;
+            M_DROP;
+            endcase;
+
+/* Double precision add. */
+        case ID_D_PLUS:  /* D+ ( al ah bl bh -- sl sh ) */
+            {
+                register ucell_t ah,al,bl,sh,sl;
+#define bh TOS
+                bl = M_POP;
+                ah = M_POP;
+                al = M_POP;
+                sh = 0;
+                sl = al + bl;
+                if( sl < bl ) sh = 1; /* Carry */
+                sh += ah + bh;
+                M_PUSH( sl );
+                TOS = sh;
+#undef bh
+            }
+            endcase;
+
+/* Double precision subtract. */
+        case ID_D_MINUS:  /* D- ( al ah bl bh -- sl sh ) */
+            {
+                register ucell_t ah,al,bl,sh,sl;
+#define bh TOS
+                bl = M_POP;
+                ah = M_POP;
+                al = M_POP;
+                sh = 0;
+                sl = al - bl;
+                if( al < bl ) sh = 1; /* Borrow */
+                sh = ah - bh - sh;
+                M_PUSH( sl );
+                TOS = sh;
+#undef bh
+            }
+            endcase;
+
+/* Assume 8-bit char and calculate cell width. */
+#define NBITS ((sizeof(ucell_t)) * 8)
+/* Define half the number of bits in a cell. */
+#define HNBITS (NBITS / 2)
+/* Assume two-complement arithmetic to calculate lower half. */
+#define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))
+#define HIGH_BIT ((ucell_t)1 << (NBITS - 1))
+
+/* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.
+ * Using an improved algorithm suggested by Steve Green.
+ * Converted to 64-bit by Aleksej Saushev.
+ */
+        case ID_D_UMTIMES:  /* UM* ( a b -- lo hi ) */
+            {
+                ucell_t ahi, alo, bhi, blo; /* input parts */
+                ucell_t lo, hi, temp;
+/* Get values from stack. */
+                ahi = M_POP;
+                bhi = TOS;
+/* Break into hi and lo 16 bit parts. */
+                alo = LOWER_HALF(ahi);
+                ahi = ahi >> HNBITS;
+                blo = LOWER_HALF(bhi);
+                bhi = bhi >> HNBITS;
+
+                lo = 0;
+                hi = 0;
+/* higher part: ahi * bhi */
+                hi += ahi * bhi;
+/* middle (overlapping) part: ahi * blo */
+                temp = ahi * blo;
+                lo += LOWER_HALF(temp);
+                hi += temp >> HNBITS;
+/* middle (overlapping) part: alo * bhi  */
+                temp = alo * bhi;
+                lo += LOWER_HALF(temp);
+                hi += temp >> HNBITS;
+/* lower part: alo * blo */
+                temp = alo * blo;
+/* its higher half overlaps with middle's lower half: */
+                lo += temp >> HNBITS;
+/* process carry: */
+                hi += lo >> HNBITS;
+                lo = LOWER_HALF(lo);
+/* combine lower part of result: */
+                lo = (lo << HNBITS) + LOWER_HALF(temp);
+
+                M_PUSH( lo );
+                TOS = hi;
+            }
+            endcase;
+
+/* Perform cell*cell bit multiply for 2 cell result, using shift and add. */
+        case ID_D_MTIMES:  /* M* ( a b -- pl ph ) */
+            {
+                ucell_t ahi, alo, bhi, blo; /* input parts */
+                ucell_t lo, hi, temp;
+                int sg;
+/* Get values from stack. */
+                ahi = M_POP;
+                bhi = TOS;
+
+/* Calculate product sign: */
+                sg = ((cell_t)(ahi ^ bhi) < 0);
+/* Take absolute values and reduce to um* */
+                if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);
+                if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);
+
+/* Break into hi and lo 16 bit parts. */
+                alo = LOWER_HALF(ahi);
+                ahi = ahi >> HNBITS;
+                blo = LOWER_HALF(bhi);
+                bhi = bhi >> HNBITS;
+
+                lo = 0;
+                hi = 0;
+/* higher part: ahi * bhi */
+                hi += ahi * bhi;
+/* middle (overlapping) part: ahi * blo */
+                temp = ahi * blo;
+                lo += LOWER_HALF(temp);
+                hi += temp >> HNBITS;
+/* middle (overlapping) part: alo * bhi  */
+                temp = alo * bhi;
+                lo += LOWER_HALF(temp);
+                hi += temp >> HNBITS;
+/* lower part: alo * blo */
+                temp = alo * blo;
+/* its higher half overlaps with middle's lower half: */
+                lo += temp >> HNBITS;
+/* process carry: */
+                hi += lo >> HNBITS;
+                lo = LOWER_HALF(lo);
+/* combine lower part of result: */
+                lo = (lo << HNBITS) + LOWER_HALF(temp);
+
+/* Negate product if one operand negative. */
+                if(sg)
+                {
+                    /* lo = (ucell_t)(- lo); */
+                    lo = ~lo + 1;
+                    hi = ~hi + ((lo == 0) ? 1 : 0);
+                }
+
+                M_PUSH( lo );
+                TOS = hi;
+            }
+            endcase;
+
+#define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
+/* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
+        case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */
+            {
+                ucell_t ah,al, q,di, bl,bh, sl,sh;
+                ah = M_POP;
+                al = M_POP;
+                bh = TOS;
+                bl = 0;
+                q = 0;
+                for( di=0; di<NBITS; di++ )
+                {
+                    if( !DULT(al,ah,bl,bh) )
+                    {
+                        sh = 0;
+                        sl = al - bl;
+                        if( al < bl ) sh = 1; /* Borrow */
+                        sh = ah - bh - sh;
+                        ah = sh;
+                        al = sl;
+                        q |= 1;
+                    }
+                    q = q << 1;
+                    bl = (bl >> 1) | (bh << (NBITS-1));
+                    bh = bh >> 1;
+                }
+                if( !DULT(al,ah,bl,bh) )
+                {
+
+                    al = al - bl;
+                    q |= 1;
+                }
+                M_PUSH( al );  /* rem */
+                TOS = q;
+            }
+            endcase;
+
+/* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */
+        case ID_D_MUSMOD:  /* MU/MOD ( al am bdiv -- rem ql qh ) */
+            {
+                register ucell_t ah,am,al,ql,qh,di;
+#define bdiv ((ucell_t)TOS)
+                ah = 0;
+                am = M_POP;
+                al = M_POP;
+                qh = ql = 0;
+                for( di=0; di<2*NBITS; di++ )
+                {
+                    if( bdiv <= ah )
+                    {
+                        ah = ah - bdiv;
+                        ql |= 1;
+                    }
+                    qh = (qh << 1) | (ql >> (NBITS-1));
+                    ql = ql << 1;
+                    ah = (ah << 1) | (am >> (NBITS-1));
+                    am = (am << 1) | (al >> (NBITS-1));
+                    al = al << 1;
+DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
+                }
+                if( bdiv <= ah )
+                {
+                    ah = ah - bdiv;
+                    ql |= 1;
+                }
+                M_PUSH( ah ); /* rem */
+                M_PUSH( ql );
+                TOS = qh;
+#undef bdiv
+            }
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_DEFER:
+            ffDefer( );
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_DEFER_P:
+            endcase;
+
+        case ID_DEPTH:
+            PUSH_TOS;
+            TOS = gCurrentTask->td_StackBase - STKPTR;
+            endcase;
+
+        case ID_DIVIDE:     BINARY_OP( / ); endcase;
+
+        case ID_DOT:
+            ffDot( TOS );
+            M_DROP;
+            endcase;
+
+        case ID_DOTS:
+            M_DOTS;
+            endcase;
+
+        case ID_DROP:  M_DROP; endcase;
+
+        case ID_DUMP:
+            Scratch = M_POP;
+            DumpMemory( (char *) Scratch, TOS );
+            M_DROP;
+            endcase;
+
+        case ID_DUP:   M_DUP; endcase;
+
+        case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
+            M_R_PUSH( TOS );
+            M_R_PUSH( M_POP );
+            M_DROP;
+            endcase;
+
+        case ID_EOL:    /* ( -- end_of_line_char ) */
+            PUSH_TOS;
+            TOS = (cell_t) '\n';
+            endcase;
+
+        case ID_ERRORQ_P:  /* ( flag num -- , quit if flag true ) */
+            Scratch = TOS;
+            M_DROP;
+            if(TOS)
+            {
+                M_THROW(Scratch);
+            }
+            else
+            {
+                M_DROP;
+            }
+            endcase;
+
+        case ID_EMIT_P:
+            EMIT( (char) TOS );
+            M_DROP;
+            endcase;
+
+        case ID_EXECUTE:
+/* Save IP on return stack like a JSR. */
+            M_R_PUSH( InsPtr );
+#ifdef PF_SUPPORT_TRACE
+/* Bump level for trace. */
+            Level++;
+#endif
+            if( IsTokenPrimitive( TOS ) )
+            {
+                WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS);   /* Build a fake secondary and execute it. */
+                InsPtr = &FakeSecondary[0];
+            }
+            else
+            {
+                InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);
+            }
+            M_DROP;
+            endcase;
+
+        case ID_FETCH:
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+            if( IN_DICS( TOS ) )
+            {
+                TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);
+            }
+            else
+            {
+                TOS = *((cell_t *)TOS);
+            }
+#else
+            TOS = *((cell_t *)TOS);
+#endif
+            endcase;
+
+        case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
+/* Build NUL terminated name string. */
+            Scratch = M_POP; /* u */
+            Temp = M_POP;    /* caddr */
+            if( Scratch < TIB_SIZE-2 )
+            {
+                const char *famText = pfSelectFileModeCreate( TOS );
+                pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
+                gScratch[Scratch] = '\0';
+                DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));
+                FileID = sdOpenFile( gScratch, famText );
+                TOS = ( FileID == NULL ) ? -1 : 0 ;
+                M_PUSH( (cell_t) FileID );
+            }
+            else
+            {
+                ERR("Filename too large for name buffer.\n");
+                M_PUSH( 0 );
+                TOS = -2;
+            }
+            endcase;
+
+        case ID_FILE_DELETE: /* ( c-addr u -- ior ) */
+/* Build NUL terminated name string. */
+            Temp = M_POP;    /* caddr */
+            if( TOS < TIB_SIZE-2 )
+            {
+                pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );
+                gScratch[TOS] = '\0';
+                DBUG(("Delete file = %s\n", gScratch ));
+                TOS = sdDeleteFile( gScratch );
+            }
+            else
+            {
+                ERR("Filename too large for name buffer.\n");
+                TOS = -2;
+            }
+            endcase;
+
+        case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
+/* Build NUL terminated name string. */
+            Scratch = M_POP; /* u */
+            Temp = M_POP;    /* caddr */
+            if( Scratch < TIB_SIZE-2 )
+            {
+                const char *famText = pfSelectFileModeOpen( TOS );
+                pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
+                gScratch[Scratch] = '\0';
+                DBUG(("Open file = %s\n", gScratch ));
+                FileID = sdOpenFile( gScratch, famText );
+
+                TOS = ( FileID == NULL ) ? -1 : 0 ;
+                M_PUSH( (cell_t) FileID );
+            }
+            else
+            {
+                ERR("Filename too large for name buffer.\n");
+                M_PUSH( 0 );
+                TOS = -2;
+            }
+            endcase;
+
+        case ID_FILE_CLOSE: /* ( fid -- ior ) */
+            TOS = sdCloseFile( (FileStream *) TOS );
+            endcase;
+
+        case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
+            FileID = (FileStream *) TOS;
+            Scratch = M_POP;
+            CharPtr = (char *) M_POP;
+            Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
+            M_PUSH(Temp);
+            TOS = 0;
+            endcase;
+
+        case ID_FILE_SIZE: /* ( fid -- ud ior ) */
+/* Determine file size by seeking to end and returning position. */
+            FileID = (FileStream *) TOS;
+            {
+                off_t endposition, offsetHi;
+                off_t original = sdTellFile( FileID );
+                sdSeekFile( FileID, 0, PF_SEEK_END );
+                endposition = sdTellFile( FileID );
+                M_PUSH(endposition);
+                /* Just use a 0 if they are the same size. */
+                offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ;
+                M_PUSH(offsetHi);
+                sdSeekFile( FileID, original, PF_SEEK_SET );
+                TOS = (original < 0) ? -4 : 0 ; /* !!! err num */
+            }
+            endcase;
+
+        case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
+            FileID = (FileStream *) TOS;
+            Scratch = M_POP;
+            CharPtr = (char *) M_POP;
+            Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
+            TOS = (Temp != Scratch) ? -3 : 0;
+            endcase;
+
+        case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */
+            {
+                off_t offset;
+                FileID = (FileStream *) TOS;
+                offset = M_POP;
+                /* Avoid compiler warnings on Mac. */
+                offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;
+                offset += M_POP;
+                TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );
+            }
+            endcase;
+
+        case ID_FILE_POSITION: /* ( fid -- ud ior ) */
+            {
+                off_t position;
+                off_t offsetHi;
+                FileID = (FileStream *) TOS;
+                position = sdTellFile( FileID );
+                M_PUSH(position);
+                /* Just use a 0 if they are the same size. */
+                offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;
+                M_PUSH(offsetHi);
+                TOS = (position < 0) ? -4 : 0 ; /* !!! err num */
+            }
+            endcase;
+
+        case ID_FILE_RO: /* (  -- fam ) */
+            PUSH_TOS;
+            TOS = PF_FAM_READ_ONLY;
+            endcase;
+
+        case ID_FILE_RW: /* ( -- fam ) */
+            PUSH_TOS;
+            TOS = PF_FAM_READ_WRITE;
+            endcase;
+
+        case ID_FILE_WO: /* ( -- fam ) */
+            PUSH_TOS;
+            TOS = PF_FAM_WRITE_ONLY;
+            endcase;
+
+        case ID_FILE_BIN: /* ( -- fam ) */
+            TOS = TOS | PF_FAM_BINARY_FLAG;
+            endcase;
+
+        case ID_FILL: /* ( caddr num charval -- ) */
+            {
+                register char *DstPtr;
+                Temp = M_POP;    /* num */
+                DstPtr = (char *) M_POP; /* dst */
+                for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
+                {
+                    *DstPtr++ = (char) TOS;
+                }
+                M_DROP;
+            }
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_FIND:  /* ( $addr -- $addr 0 | xt +-1 ) */
+            TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
+            M_PUSH( Temp );
+            endcase;
+
+        case ID_FINDNFA:
+            TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
+            M_PUSH( (cell_t) Temp );
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_FLUSHEMIT:
+            sdTerminalFlush();
+            endcase;
+
+/* Validate memory before freeing. Clobber validator and first word. */
+        case ID_FREE:   /* ( addr -- result ) */
+            if( TOS == 0 )
+            {
+                ERR("FREE passed NULL!\n");
+                TOS = -2; /* FIXME error code */
+            }
+            else
+            {
+                CellPtr = (cell_t *) TOS;
+                CellPtr--;
+                if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
+                {
+                    TOS = -2; /* FIXME error code */
+                }
+                else
+                {
+                    CellPtr[0] = 0xDeadBeef;
+                    pfFreeMem((char *)CellPtr);
+                    TOS = 0;
+                }
+            }
+            endcase;
+
+#include "pfinnrfp.h"
+
+        case ID_HERE:
+            PUSH_TOS;
+            TOS = (cell_t)CODE_HERE;
+            endcase;
+
+        case ID_NUMBERQ_P:   /* ( addr -- 0 | n 1 ) */
+/* Convert using number converter in 'C'.
+** Only supports single precision for bootstrap.
+*/
+            TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
+            if( TOS == NUM_TYPE_SINGLE)
+            {
+                M_PUSH( Temp );   /* Push single number */
+            }
+            endcase;
+
+        case ID_I:  /* ( -- i , DO LOOP index ) */
+            PUSH_TOS;
+            TOS = M_R_PICK(1);
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_INCLUDE_FILE:
+            FileID = (FileStream *) TOS;
+            M_DROP;    /* Drop now so that INCLUDE has a clean stack. */
+            SAVE_REGISTERS;
+            Scratch = ffIncludeFile( FileID );
+            LOAD_REGISTERS;
+            if( Scratch ) M_THROW(Scratch)
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+#ifndef PF_NO_SHELL
+        case ID_INTERPRET:
+            SAVE_REGISTERS;
+            Scratch = ffInterpret();
+            LOAD_REGISTERS;
+            if( Scratch ) M_THROW(Scratch)
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_J:  /* ( -- j , second DO LOOP index ) */
+            PUSH_TOS;
+            TOS = M_R_PICK(3);
+            endcase;
+
+        case ID_KEY:
+            PUSH_TOS;
+            TOS = ioKey();
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_LITERAL:
+            ffLiteral( TOS );
+            M_DROP;
+            endcase;
+#endif /* !PF_NO_SHELL */
+
+        case ID_LITERAL_P:
+            DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
+            PUSH_TOS;
+            TOS = READ_CELL_DIC(InsPtr++);
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
+#endif /* !PF_NO_SHELL */
+
+        case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
+            TOS = *(LocalsPtr - TOS);
+            endcase;
+
+#define LOCAL_FETCH_N(num) \
+        case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
+            PUSH_TOS; \
+            TOS = *(LocalsPtr -(num)); \
+            endcase;
+
+        LOCAL_FETCH_N(1);
+        LOCAL_FETCH_N(2);
+        LOCAL_FETCH_N(3);
+        LOCAL_FETCH_N(4);
+        LOCAL_FETCH_N(5);
+        LOCAL_FETCH_N(6);
+        LOCAL_FETCH_N(7);
+        LOCAL_FETCH_N(8);
+
+        case ID_LOCAL_STORE:  /* ( n i <local> -- , store n in local ) */
+            *(LocalsPtr - TOS) = M_POP;
+            M_DROP;
+            endcase;
+
+#define LOCAL_STORE_N(num) \
+        case ID_LOCAL_STORE_##num:  /* ( n <local> -- , store n in local ) */ \
+            *(LocalsPtr - (num)) = TOS; \
+            M_DROP; \
+            endcase;
+
+        LOCAL_STORE_N(1);
+        LOCAL_STORE_N(2);
+        LOCAL_STORE_N(3);
+        LOCAL_STORE_N(4);
+        LOCAL_STORE_N(5);
+        LOCAL_STORE_N(6);
+        LOCAL_STORE_N(7);
+        LOCAL_STORE_N(8);
+
+        case ID_LOCAL_PLUSSTORE:  /* ( n i <local> -- , add n to local ) */
+            *(LocalsPtr - TOS) += M_POP;
+            M_DROP;
+            endcase;
+
+        case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
+        /* create local stack frame */
+            {
+                cell_t i = TOS;
+                cell_t *lp;
+                DBUG(("LocalEntry: n = %d\n", TOS));
+                /* End of locals. Create stack frame */
+                DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
+                    TORPTR, LocalsPtr));
+                M_R_PUSH(LocalsPtr);
+                LocalsPtr = TORPTR;
+                TORPTR -= TOS;
+                DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
+                    TORPTR, LocalsPtr));
+                lp = TORPTR;
+                while(i-- > 0)
+                {
+                    *lp++ = M_POP;    /* Load local vars from stack */
+                }
+                M_DROP;
+            }
+            endcase;
+
+        case ID_LOCAL_EXIT: /* cleanup up local stack frame */
+            DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
+                TORPTR, LocalsPtr));
+            TORPTR = LocalsPtr;
+            LocalsPtr = (cell_t *) M_R_POP;
+            DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
+                TORPTR, LocalsPtr));
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_LOADSYS:
+            MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
+            FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
+            if( FileID )
+            {
+                SAVE_REGISTERS;
+                Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
+                LOAD_REGISTERS;
+                if( Scratch ) M_THROW(Scratch);
+            }
+            else
+            {
+                 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
+            }
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_LEAVE_P: /* ( R: index limit --  ) */
+            M_R_DROP;
+            M_R_DROP;
+            M_BRANCH;
+            endcase;
+
+        case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
+            Temp = M_R_POP; /* limit */
+            Scratch = M_R_POP + 1; /* index */
+            if( Scratch == Temp )
+            {
+                InsPtr++;   /* skip branch offset, exit loop */
+            }
+            else
+            {
+/* Push index and limit back to R */
+                M_R_PUSH( Scratch );
+                M_R_PUSH( Temp );
+/* Branch back to just after (DO) */
+                M_BRANCH;
+            }
+            endcase;
+
+        case ID_LSHIFT:     BINARY_OP( << ); endcase;
+
+        case ID_MAX:
+            Scratch = M_POP;
+            TOS = ( TOS > Scratch ) ? TOS : Scratch ;
+            endcase;
+
+        case ID_MIN:
+            Scratch = M_POP;
+            TOS = ( TOS < Scratch ) ? TOS : Scratch ;
+            endcase;
+
+        case ID_MINUS:     BINARY_OP( - ); endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_NAME_TO_TOKEN:
+            TOS = (cell_t) NameToToken((ForthString *)TOS);
+            endcase;
+
+        case ID_NAME_TO_PREVIOUS:
+            TOS = (cell_t) NameToPrevious((ForthString *)TOS);
+            endcase;
+#endif
+
+        case ID_NOOP:
+            endcase;
+
+        case ID_OR:     BINARY_OP( | ); endcase;
+
+        case ID_OVER:
+            PUSH_TOS;
+            TOS = M_STACK(1);
+            endcase;
+
+        case ID_PICK: /* ( ... n -- sp(n) ) */
+            TOS = M_STACK(TOS);
+            endcase;
+
+        case ID_PLUS:     BINARY_OP( + ); endcase;
+
+        case ID_PLUS_STORE:   /* ( n addr -- , add n to *addr ) */
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+            if( IN_DICS( TOS ) )
+            {
+                Scratch = READ_CELL_DIC((cell_t *)TOS);
+                Scratch += M_POP;
+                WRITE_CELL_DIC((cell_t *)TOS,Scratch);
+            }
+            else
+            {
+                *((cell_t *)TOS) += M_POP;
+            }
+#else
+            *((cell_t *)TOS) += M_POP;
+#endif
+            M_DROP;
+            endcase;
+
+        case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
+            {
+                ucell_t OldIndex, NewIndex, Limit;
+
+                Limit = M_R_POP;
+                OldIndex = M_R_POP;
+                NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */
+/* Do indices cross boundary between LIMIT-1 and LIMIT ? */
+                if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
+                    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
+                {
+                    InsPtr++;   /* skip branch offset, exit loop */
+                }
+                else
+                {
+/* Push index and limit back to R */
+                    M_R_PUSH( NewIndex );
+                    M_R_PUSH( Limit );
+/* Branch back to just after (DO) */
+                    M_BRANCH;
+                }
+                M_DROP;
+            }
+            endcase;
+
+        case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
+            Scratch = M_POP;  /* limit */
+            if( Scratch == TOS )
+            {
+/* Branch to just after (LOOP) */
+                M_BRANCH;
+            }
+            else
+            {
+                M_R_PUSH( TOS );
+                M_R_PUSH( Scratch );
+                InsPtr++;   /* skip branch offset, enter loop */
+            }
+            M_DROP;
+            endcase;
+
+        case ID_QDUP:     if( TOS ) M_DUP; endcase;
+
+        case ID_QTERMINAL:  /* WARNING: Typically not fully implemented! */
+            PUSH_TOS;
+            TOS = sdQueryTerminal();
+            endcase;
+
+        case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
+#ifdef PF_SUPPORT_TRACE
+            Level = 0;
+#endif
+            M_THROW(THROW_QUIT);
+            endcase;
+
+        case ID_R_DROP:
+            M_R_DROP;
+            endcase;
+
+        case ID_R_FETCH:
+            PUSH_TOS;
+            TOS = (*(TORPTR));
+            endcase;
+
+        case ID_R_FROM:
+            PUSH_TOS;
+            TOS = M_R_POP;
+            endcase;
+
+        case ID_REFILL:
+            PUSH_TOS;
+            TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
+            endcase;
+
+/* Resize memory allocated by ALLOCATE. */
+        case ID_RESIZE:  /* ( addr1 u -- addr2 result ) */
+            {
+                cell_t *Addr1 = (cell_t *) M_POP;
+                /* Point to validator below users address. */
+                cell_t *FreePtr = Addr1 - 1;
+                if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
+                {
+                    /* 090218 - Fixed bug, was returning zero. */
+                    M_PUSH( Addr1 );
+                    TOS = -3;
+                }
+                else
+                {
+                    /* Try to allocate. */
+                    CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
+                    if( CellPtr )
+                    {
+                        /* Copy memory including validation. */
+                        pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
+                        *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
+                        /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
+                        /* Increment past validator to user address. */
+                        M_PUSH( (cell_t) (CellPtr + 1) );
+                        TOS = 0; /* Result code. */
+                        /* Mark old cell as dead so we can't free it twice. */
+                        FreePtr[0] = 0xDeadBeef;
+                        pfFreeMem((char *) FreePtr);
+                    }
+                    else
+                    {
+                        /* 090218 - Fixed bug, was returning zero. */
+                        M_PUSH( Addr1 );
+                        TOS = -4;  /* FIXME Fix error code. */
+                    }
+                }
+            }
+            endcase;
+
+/*
+** RP@ and RP! are called secondaries so we must
+** account for the return address pushed before calling.
+*/
+        case ID_RP_FETCH:    /* ( -- rp , address of top of return stack ) */
+            PUSH_TOS;
+            TOS = (cell_t)TORPTR;  /* value before calling RP@ */
+            endcase;
+
+        case ID_RP_STORE:    /* ( rp -- , address of top of return stack ) */
+            TORPTR = (cell_t *) TOS;
+            M_DROP;
+            endcase;
+
+        case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
+            {
+                cell_t ri;
+                cell_t *srcPtr, *dstPtr;
+                Scratch = M_STACK(TOS);
+                srcPtr = &M_STACK(TOS-1);
+                dstPtr = &M_STACK(TOS);
+                for( ri=0; ri<TOS; ri++ )
+                {
+                    *dstPtr-- = *srcPtr--;
+                }
+                TOS = Scratch;
+                STKPTR++;
+            }
+            endcase;
+
+        case ID_ROT:  /* ( a b c -- b c a ) */
+            Scratch = M_POP;    /* b */
+            Temp = M_POP;       /* a */
+            M_PUSH( Scratch );  /* b */
+            PUSH_TOS;           /* c */
+            TOS = Temp;         /* a */
+            endcase;
+
+/* Logical right shift */
+        case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_SAVE_FORTH_P:   /* ( $name Entry NameSize CodeSize -- err ) */
+            {
+                cell_t NameSize, CodeSize, EntryPoint;
+                CodeSize = TOS;
+                NameSize = M_POP;
+                EntryPoint = M_POP;
+                ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
+                TOS =  ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
+            }
+            endcase;
+#endif
+
+/* Source     Stack
+** EVALUATE    >IN  SourceID=(-1)  1111
+** keyboard    >IN  SourceID=(0)   2222
+** file        >IN  lineNumber filePos  SourceID=(fileID)
+*/
+        case ID_SAVE_INPUT:  /* FIXME - finish */
+            {
+            }
+            endcase;
+
+        case ID_SP_FETCH:    /* ( -- sp , address of top of stack, sorta ) */
+            PUSH_TOS;
+            TOS = (cell_t)STKPTR;
+            endcase;
+
+        case ID_SP_STORE:    /* ( sp -- , address of top of stack, sorta ) */
+            STKPTR = (cell_t *) TOS;
+            M_DROP;
+            endcase;
+
+        case ID_STORE: /* ( n addr -- , write n to addr ) */
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+            if( IN_DICS( TOS ) )
+            {
+                WRITE_CELL_DIC((cell_t *)TOS,M_POP);
+            }
+            else
+            {
+                *((cell_t *)TOS) = M_POP;
+            }
+#else
+            *((cell_t *)TOS) = M_POP;
+#endif
+            M_DROP;
+            endcase;
+
+        case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
+            Scratch = M_POP; /* cnt */
+            Temp = M_POP;    /* addr */
+            TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
+            M_PUSH((cell_t) CharPtr);
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_SEMICOLON:
+            SAVE_REGISTERS;
+            Scratch = ffSemiColon();
+            LOAD_REGISTERS;
+            if( Scratch ) M_THROW( Scratch );
+            endcase;
+#endif /* !PF_NO_SHELL */
+
+        case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
+            Scratch = M_POP; /* cnt */
+            Temp = M_POP;    /* addr */
+            TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
+            M_PUSH((cell_t) CharPtr);
+            endcase;
+
+        case ID_SOURCE:  /* ( -- c-addr num ) */
+            PUSH_TOS;
+            M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
+            TOS = (cell_t) gCurrentTask->td_SourceNum;
+            endcase;
+
+        case ID_SOURCE_SET: /* ( c-addr num -- ) */
+            gCurrentTask->td_SourcePtr = (char *) M_POP;
+            gCurrentTask->td_SourceNum = TOS;
+            M_DROP;
+            endcase;
+
+        case ID_SOURCE_ID:
+            PUSH_TOS;
+            TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
+            endcase;
+
+        case ID_SOURCE_ID_POP:
+            PUSH_TOS;
+            TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
+            endcase;
+
+        case ID_SOURCE_ID_PUSH:  /* ( source-id -- ) */
+            TOS = (cell_t)ffConvertSourceIDToStream( TOS );
+            Scratch = ffPushInputStream((FileStream *) TOS );
+            if( Scratch )
+            {
+                M_THROW(Scratch);
+            }
+            else M_DROP;
+            endcase;
+
+        case ID_SWAP:
+            Scratch = TOS;
+            TOS = *STKPTR;
+            *STKPTR = Scratch;
+            endcase;
+
+        case ID_TEST1:
+            PUSH_TOS;
+            M_PUSH( 0x11 );
+            M_PUSH( 0x22 );
+            TOS = 0x33;
+            endcase;
+
+        case ID_TEST2:
+            endcase;
+
+        case ID_THROW:  /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
+            if(TOS)
+            {
+                M_THROW(TOS);
+            }
+            else M_DROP;
+            endcase;
+
+#ifndef PF_NO_SHELL
+        case ID_TICK:
+            PUSH_TOS;
+            CharPtr = (char *) ffWord( (char) ' ' );
+            TOS = ffFind( CharPtr, (ExecToken *) &Temp );
+            if( TOS == 0 )
+            {
+                ERR("' could not find ");
+                ioType( (char *) CharPtr+1, *CharPtr );
+                M_THROW(-13);
+            }
+            else
+            {
+                TOS = Temp;
+            }
+            endcase;
+#endif  /* !PF_NO_SHELL */
+
+        case ID_TIMES: BINARY_OP( * ); endcase;
+
+        case ID_TYPE:
+            Scratch = M_POP; /* addr */
+            ioType( (char *) Scratch, TOS );
+            M_DROP;
+            endcase;
+
+        case ID_TO_R:
+            M_R_PUSH( TOS );
+            M_DROP;
+            endcase;
+
+        case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
+        case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
+        case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
+        case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
+        case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
+        case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
+        case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
+        case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
+        case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
+        case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
+        case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
+        case ID_VAR_STATE: DO_VAR(gVarState); endcase;
+        case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
+        case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
+        case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
+        case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
+        case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
+
+        case ID_WORD:
+            TOS = (cell_t) ffWord( (char) TOS );
+            endcase;
+
+        case ID_WORD_FETCH: /* ( waddr -- w ) */
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+            if( IN_DICS( TOS ) )
+            {
+                TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
+            }
+            else
+            {
+                TOS = *((uint16_t *)TOS);
+            }
+#else
+            TOS = *((uint16_t *)TOS);
+#endif
+            endcase;
+
+        case ID_WORD_STORE: /* ( w waddr -- ) */
+
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+            if( IN_DICS( TOS ) )
+            {
+                WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
+            }
+            else
+            {
+                *((uint16_t *)TOS) = (uint16_t) M_POP;
+            }
+#else
+            *((uint16_t *)TOS) = (uint16_t) M_POP;
+#endif
+            M_DROP;
+            endcase;
+
+        case ID_XOR: BINARY_OP( ^ ); endcase;
+
+
+/* Branch is followed by an offset relative to address of offset. */
+        case ID_ZERO_BRANCH:
+DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
+            if( TOS == 0 )
+            {
+                M_BRANCH;
+            }
+            else
+            {
+                InsPtr++;      /* skip over offset */
+            }
+            M_DROP;
+DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
+            endcase;
+
+        default:
+            ERR("pfCatch: Unrecognised token = 0x");
+            ffDotHex(Token);
+            ERR(" at 0x");
+            ffDotHex((cell_t) InsPtr);
+            EMIT_CR;
+            InsPtr = 0;
+            endcase;
+        }
+
+        if(InsPtr) Token = READ_CELL_DIC(InsPtr++);   /* Traverse to next token in secondary. */
+
+#ifdef PF_DEBUG
+        M_DOTS;
+#endif
+
+#if 0
+        if( _CrtCheckMemory() == 0 )
+        {
+            ERR("_CrtCheckMemory abort: InsPtr = 0x");
+            ffDotHex((int)InsPtr);
+            ERR("\n");
+        }
+#endif
+
+    } while( (InitialReturnStack - TORPTR) > 0 );
+
+    SAVE_REGISTERS;
+
+    return ExceptionReturnCode;
+}

diff --git a/csrc/pf_io.c b/csrc/pf_io.c
index dc5a9dc..3aedb49 100644 (file)
--- a/csrc/pf_io.c
+++ b/csrc/pf_io.c
@@ -1,225 +1,225 @@
-/* @(#) pf_io.c 96/12/23 1.12 */\r
-/***************************************************************\r
-** I/O subsystem for PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-\r
-/***************************************************************\r
-** Initialize I/O system.\r
-*/\r
-void ioInit( void )\r
-{\r
-       /* System dependant terminal initialization. */\r
-       sdTerminalInit();\r
-}\r
-void ioTerm( void )\r
-{\r
-       sdTerminalTerm();\r
-}\r
-\r
-/***************************************************************\r
-** Send single character to output stream.\r
-*/\r
-void ioEmit( char c )\r
-{\r
-       cell_t Result;\r
-       \r
-       Result = sdTerminalOut(c);\r
-       if( Result < 0 ) EXIT(1);\r
-       \r
-       if( gCurrentTask )\r
-       {\r
-               if(c == '\n')\r
-               {\r
-                       gCurrentTask->td_OUT = 0;\r
-                       sdTerminalFlush();\r
-               }\r
-               else\r
-               {\r
-                       gCurrentTask->td_OUT++;\r
-               }\r
-       }\r
-}\r
-\r
-/***************************************************************\r
-** Send an entire string..\r
-*/\r
-void ioType( const char *s, cell_t n )\r
-{\r
-       cell_t i;\r
-\r
-       for( i=0; i<n; i++)\r
-       {\r
-               ioEmit ( *s++ );\r
-       }\r
-}\r
-\r
-/***************************************************************\r
-** Return single character from input device, always keyboard.\r
-*/\r
-cell_t ioKey( void )\r
-{\r
-       cell_t c;\r
-       sdEnableInput();\r
-       c = sdTerminalIn();\r
-       sdDisableInput();\r
-       return c;\r
-}\r
-\r
-/**************************************************************\r
-** Receive line from keyboard.\r
-** Return number of characters enterred.\r
-*/\r
-#define SPACE      (0x20)\r
-#define BACKSPACE  (0x08)\r
-#define DELETE     (0x7F)\r
-cell_t ioAccept( char *buffer, cell_t maxChars )\r
-{\r
-       int c;\r
-       int len;\r
-       char *p;\r
-\r
-DBUGX(("ioAccept(0x%x, 0x%x)\n", buffer, len ));\r
-       \r
-       sdEnableInput();\r
-\r
-       p = buffer;\r
-       len = 0;\r
-       while(len < maxChars)\r
-       {\r
-               c = sdTerminalIn();\r
-               switch(c)\r
-               {\r
-                       case '\r':\r
-                       case '\n':\r
-                               DBUGX(("EOL\n"));\r
-                               goto gotline;\r
-                               break;\r
-                               \r
-                       case BACKSPACE:\r
-                       case DELETE:\r
-                               if( len > 0 )  /* Don't go beyond beginning of line. */\r
-                               {\r
-                                       EMIT(BACKSPACE);\r
-                                       EMIT(' ');\r
-                                       EMIT(BACKSPACE);\r
-                                       p--;\r
-                                       len--;\r
-                               }\r
-                               break;\r
-                               \r
-                       default:\r
-                               sdTerminalEcho( (char) c );\r
-                               *p++ = (char) c;\r
-                               len++;\r
-                               break;\r
-               }\r
-               \r
-       }\r
-\r
-gotline:\r
-       sdDisableInput();\r
-       sdTerminalEcho( SPACE );\r
-\r
-/* NUL terminate line to simplify printing when debugging. */\r
-       if( len < maxChars ) p[len] = '\0';\r
-               \r
-       return len;\r
-}\r
-\r
-#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); }\r
-\r
-\r
-/***********************************************************************************/\r
-/*********** File I/O **************************************************************/\r
-/***********************************************************************************/\r
-#ifdef PF_NO_FILEIO\r
-\r
-/* Provide stubs for standard file I/O */\r
-\r
-FileStream *PF_STDIN;\r
-FileStream *PF_STDOUT;\r
-\r
-cell_t  sdInputChar( FileStream *stream )\r
-{\r
-       UNIMPLEMENTED("sdInputChar");\r
-       TOUCH(stream);\r
-       return -1;\r
-}\r
-\r
-FileStream *sdOpenFile( const char *FileName, const char *Mode )\r
-{\r
-       UNIMPLEMENTED("sdOpenFile");\r
-       TOUCH(FileName);\r
-       TOUCH(Mode);\r
-       return NULL;\r
-}\r
-cell_t sdFlushFile( FileStream * Stream  )\r
-{\r
-       TOUCH(Stream);\r
-       return 0;\r
-}\r
-cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  ) \r
-{ \r
-       UNIMPLEMENTED("sdReadFile");\r
-       TOUCH(ptr);\r
-       TOUCH(Size);\r
-       TOUCH(nItems);\r
-       TOUCH(Stream);\r
-       return 0; \r
-}\r
-cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  )\r
-{ \r
-       UNIMPLEMENTED("sdWriteFile");\r
-       TOUCH(ptr);\r
-       TOUCH(Size);\r
-       TOUCH(nItems);\r
-       TOUCH(Stream);\r
-       return 0; \r
-}\r
-cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode ) \r
-{ \r
-       UNIMPLEMENTED("sdSeekFile");\r
-       TOUCH(Stream);\r
-       TOUCH(Position);\r
-       TOUCH(Mode);\r
-       return 0; \r
-}\r
-cell_t sdTellFile( FileStream * Stream ) \r
-{ \r
-       UNIMPLEMENTED("sdTellFile");\r
-       TOUCH(Stream);\r
-       return 0; \r
-}\r
-cell_t sdCloseFile( FileStream * Stream ) \r
-{ \r
-       UNIMPLEMENTED("sdCloseFile");\r
-       TOUCH(Stream);\r
-       return 0; \r
-}\r
-\r
-FileStream *sdDeleteFile( const char *FileName )\r
-{\r
-       UNIMPLEMENTED("sdDeleteFile");\r
-       TOUCH(FileName);\r
-       return NULL;\r
-}\r
-#endif\r
-\r
+/* @(#) pf_io.c 96/12/23 1.12 */
+/***************************************************************
+** I/O subsystem for PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+***************************************************************/
+
+#include "pf_all.h"
+
+
+/***************************************************************
+** Initialize I/O system.
+*/
+void ioInit( void )
+{
+    /* System dependant terminal initialization. */
+    sdTerminalInit();
+}
+void ioTerm( void )
+{
+    sdTerminalTerm();
+}
+
+/***************************************************************
+** Send single character to output stream.
+*/
+void ioEmit( char c )
+{
+    cell_t Result;
+
+    Result = sdTerminalOut(c);
+    if( Result < 0 ) EXIT(1);
+
+    if( gCurrentTask )
+    {
+        if(c == '\n')
+        {
+            gCurrentTask->td_OUT = 0;
+            sdTerminalFlush();
+        }
+        else
+        {
+            gCurrentTask->td_OUT++;
+        }
+    }
+}
+
+/***************************************************************
+** Send an entire string..
+*/
+void ioType( const char *s, cell_t n )
+{
+    cell_t i;
+
+    for( i=0; i<n; i++)
+    {
+        ioEmit ( *s++ );
+    }
+}
+
+/***************************************************************
+** Return single character from input device, always keyboard.
+*/
+cell_t ioKey( void )
+{
+    cell_t c;
+    sdEnableInput();
+    c = sdTerminalIn();
+    sdDisableInput();
+    return c;
+}
+
+/**************************************************************
+** Receive line from keyboard.
+** Return number of characters enterred.
+*/
+#define SPACE      (0x20)
+#define BACKSPACE  (0x08)
+#define DELETE     (0x7F)
+cell_t ioAccept( char *buffer, cell_t maxChars )
+{
+    int c;
+    int len;
+    char *p;
+
+DBUGX(("ioAccept(0x%x, 0x%x)\n", buffer, len ));
+
+    sdEnableInput();
+
+    p = buffer;
+    len = 0;
+    while(len < maxChars)
+    {
+        c = sdTerminalIn();
+        switch(c)
+        {
+            case '\r':
+            case '\n':
+                DBUGX(("EOL\n"));
+                goto gotline;
+                break;
+
+            case BACKSPACE:
+            case DELETE:
+                if( len > 0 )  /* Don't go beyond beginning of line. */
+                {
+                    EMIT(BACKSPACE);
+                    EMIT(' ');
+                    EMIT(BACKSPACE);
+                    p--;
+                    len--;
+                }
+                break;
+
+            default:
+                sdTerminalEcho( (char) c );
+                *p++ = (char) c;
+                len++;
+                break;
+        }
+
+    }
+
+gotline:
+    sdDisableInput();
+    sdTerminalEcho( SPACE );
+
+/* NUL terminate line to simplify printing when debugging. */
+    if( len < maxChars ) p[len] = '\0';
+
+    return len;
+}
+
+#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); }
+
+
+/***********************************************************************************/
+/*********** File I/O **************************************************************/
+/***********************************************************************************/
+#ifdef PF_NO_FILEIO
+
+/* Provide stubs for standard file I/O */
+
+FileStream *PF_STDIN;
+FileStream *PF_STDOUT;
+
+cell_t  sdInputChar( FileStream *stream )
+{
+    UNIMPLEMENTED("sdInputChar");
+    TOUCH(stream);
+    return -1;
+}
+
+FileStream *sdOpenFile( const char *FileName, const char *Mode )
+{
+    UNIMPLEMENTED("sdOpenFile");
+    TOUCH(FileName);
+    TOUCH(Mode);
+    return NULL;
+}
+cell_t sdFlushFile( FileStream * Stream  )
+{
+    TOUCH(Stream);
+    return 0;
+}
+cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  )
+{
+    UNIMPLEMENTED("sdReadFile");
+    TOUCH(ptr);
+    TOUCH(Size);
+    TOUCH(nItems);
+    TOUCH(Stream);
+    return 0;
+}
+cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  )
+{
+    UNIMPLEMENTED("sdWriteFile");
+    TOUCH(ptr);
+    TOUCH(Size);
+    TOUCH(nItems);
+    TOUCH(Stream);
+    return 0;
+}
+cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode )
+{
+    UNIMPLEMENTED("sdSeekFile");
+    TOUCH(Stream);
+    TOUCH(Position);
+    TOUCH(Mode);
+    return 0;
+}
+cell_t sdTellFile( FileStream * Stream )
+{
+    UNIMPLEMENTED("sdTellFile");
+    TOUCH(Stream);
+    return 0;
+}
+cell_t sdCloseFile( FileStream * Stream )
+{
+    UNIMPLEMENTED("sdCloseFile");
+    TOUCH(Stream);
+    return 0;
+}
+
+FileStream *sdDeleteFile( const char *FileName )
+{
+    UNIMPLEMENTED("sdDeleteFile");
+    TOUCH(FileName);
+    return NULL;
+}
+#endif
+

diff --git a/csrc/pf_io.h b/csrc/pf_io.h
index beb3495..e03b034 100644 (file)
--- a/csrc/pf_io.h
+++ b/csrc/pf_io.h
@@ -1,162 +1,162 @@
-/* @(#) pf_io.h 98/01/26 1.2 */\r
-#ifndef _pf_io_h\r
-#define _pf_io_h\r
-\r
-/***************************************************************\r
-** Include file for PForth IO\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#define PF_CHAR_XON    (0x11)\r
-#define PF_CHAR_XOFF   (0x13)   \r
-\r
-int  sdTerminalOut( char c );\r
-int  sdTerminalEcho( char c );\r
-int  sdTerminalFlush( void );\r
-int  sdTerminalIn( void );\r
-int  sdQueryTerminal( void );\r
-void sdTerminalInit( void );\r
-void sdTerminalTerm( void );\r
-\r
-void ioInit( void );\r
-void ioTerm( void );\r
-\r
-\r
-#ifdef PF_NO_CHARIO\r
-       void sdEnableInput( void );\r
-       void sdDisableInput( void );\r
-\r
-#else   /* PF_NO_CHARIO */\r
-       #ifdef PF_USER_CHARIO\r
-/* Get user prototypes or macros from include file.\r
-** API must match that defined above for the stubs.\r
-*/\r
-/* If your sdTerminalIn echos, define PF_KEY_ECHOS. */\r
-               #include PF_USER_CHARIO\r
-       #else\r
-               #define sdEnableInput()     /* sdTerminalOut( PF_CHAR_XON ) */\r
-               #define sdDisableInput()    /* sdTerminalOut( PF_CHAR_XOFF ) */\r
-               \r
-       #endif\r
-#endif   /* PF_NO_CHARIO */\r
-\r
-/* Define file access modes. */\r
-/* User can #undef and re#define using PF_USER_FILEIO if needed. */\r
-#define PF_FAM_READ_ONLY   (0)\r
-#define PF_FAM_READ_WRITE  (1)\r
-#define PF_FAM_WRITE_ONLY  (2)\r
-#define PF_FAM_BINARY_FLAG (8)\r
-\r
-#define PF_FAM_CREATE_WO      ("w")\r
-#define PF_FAM_CREATE_RW      ("w+")\r
-#define PF_FAM_OPEN_RO        ("r")\r
-#define PF_FAM_OPEN_RW        ("r+")\r
-#define PF_FAM_BIN_CREATE_WO  ("wb")\r
-#define PF_FAM_BIN_CREATE_RW  ("wb+")\r
-#define PF_FAM_BIN_OPEN_RO    ("rb")\r
-#define PF_FAM_BIN_OPEN_RW    ("rb+")\r
-\r
-#ifdef PF_NO_FILEIO\r
-\r
-       typedef void FileStream;\r
-\r
-       extern FileStream *PF_STDIN;\r
-       extern FileStream *PF_STDOUT;\r
-\r
-       #ifdef __cplusplus\r
-       extern "C" {\r
-       #endif\r
-       \r
-       /* Prototypes for stubs. */\r
-       FileStream *sdOpenFile( const char *FileName, const char *Mode );\r
-       cell_t sdFlushFile( FileStream * Stream  );\r
-       cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );\r
-       cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );\r
-       cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode );\r
-       off_t sdTellFile( FileStream * Stream );\r
-       cell_t sdCloseFile( FileStream * Stream );\r
-       cell_t sdInputChar( FileStream *stream );\r
-       \r
-       #ifdef __cplusplus\r
-       }   \r
-       #endif\r
-       \r
-       #define  PF_SEEK_SET   (0)\r
-       #define  PF_SEEK_CUR   (1)\r
-       #define  PF_SEEK_END   (2)\r
-       /*\r
-       ** printf() is only used for debugging purposes.\r
-       ** It is not required for normal operation.\r
-       */\r
-       #define PRT(x) /* No printf(). */\r
-\r
-#else\r
-\r
-       #ifdef PF_USER_FILEIO\r
-/* Get user prototypes or macros from include file.\r
-** API must match that defined above for the stubs.\r
-*/\r
-               #include PF_USER_FILEIO\r
-               \r
-       #else\r
-               typedef FILE FileStream;\r
-\r
-               #define sdOpenFile      fopen\r
-               #define sdDeleteFile      remove\r
-               #define sdFlushFile     fflush\r
-               #define sdReadFile      fread\r
-               #define sdWriteFile     fwrite\r
-               #if defined(WIN32) || defined(__NT__)\r
-                       /* TODO To support 64-bit file offset we probably need fseeki64(). */\r
-                       #define sdSeekFile      fseek\r
-                       #define sdTellFile      ftell\r
-               #else\r
-                       #define sdSeekFile      fseeko\r
-                       #define sdTellFile      ftello\r
-               #endif\r
-               #define sdCloseFile     fclose\r
-               #define sdInputChar     fgetc\r
-               \r
-               #define PF_STDIN  ((FileStream *) stdin)\r
-               #define PF_STDOUT ((FileStream *) stdout)\r
-               \r
-               #define  PF_SEEK_SET   (0)\r
-               #define  PF_SEEK_CUR   (1)\r
-               #define  PF_SEEK_END   (2)\r
-               \r
-               /*\r
-               ** printf() is only used for debugging purposes.\r
-               ** It is not required for normal operation.\r
-               */\r
-               #define PRT(x) { printf x; sdFlushFile(PF_STDOUT); }\r
-       #endif\r
-\r
-#endif  /* PF_NO_FILEIO */\r
-\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-cell_t ioAccept( char *Target, cell_t n1 );\r
-cell_t ioKey( void);\r
-void ioEmit( char c );\r
-void ioType( const char *s, cell_t n);\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pf_io_h */\r
+/* @(#) pf_io.h 98/01/26 1.2 */
+#ifndef _pf_io_h
+#define _pf_io_h
+
+/***************************************************************
+** Include file for PForth IO
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#define PF_CHAR_XON    (0x11)
+#define PF_CHAR_XOFF   (0x13)
+
+int  sdTerminalOut( char c );
+int  sdTerminalEcho( char c );
+int  sdTerminalFlush( void );
+int  sdTerminalIn( void );
+int  sdQueryTerminal( void );
+void sdTerminalInit( void );
+void sdTerminalTerm( void );
+
+void ioInit( void );
+void ioTerm( void );
+
+
+#ifdef PF_NO_CHARIO
+    void sdEnableInput( void );
+    void sdDisableInput( void );
+
+#else   /* PF_NO_CHARIO */
+    #ifdef PF_USER_CHARIO
+/* Get user prototypes or macros from include file.
+** API must match that defined above for the stubs.
+*/
+/* If your sdTerminalIn echos, define PF_KEY_ECHOS. */
+        #include PF_USER_CHARIO
+    #else
+        #define sdEnableInput()     /* sdTerminalOut( PF_CHAR_XON ) */
+        #define sdDisableInput()    /* sdTerminalOut( PF_CHAR_XOFF ) */
+
+    #endif
+#endif   /* PF_NO_CHARIO */
+
+/* Define file access modes. */
+/* User can #undef and re#define using PF_USER_FILEIO if needed. */
+#define PF_FAM_READ_ONLY   (0)
+#define PF_FAM_READ_WRITE  (1)
+#define PF_FAM_WRITE_ONLY  (2)
+#define PF_FAM_BINARY_FLAG (8)
+
+#define PF_FAM_CREATE_WO      ("w")
+#define PF_FAM_CREATE_RW      ("w+")
+#define PF_FAM_OPEN_RO        ("r")
+#define PF_FAM_OPEN_RW        ("r+")
+#define PF_FAM_BIN_CREATE_WO  ("wb")
+#define PF_FAM_BIN_CREATE_RW  ("wb+")
+#define PF_FAM_BIN_OPEN_RO    ("rb")
+#define PF_FAM_BIN_OPEN_RW    ("rb+")
+
+#ifdef PF_NO_FILEIO
+
+    typedef void FileStream;
+
+    extern FileStream *PF_STDIN;
+    extern FileStream *PF_STDOUT;
+
+    #ifdef __cplusplus
+    extern "C" {
+    #endif
+
+    /* Prototypes for stubs. */
+    FileStream *sdOpenFile( const char *FileName, const char *Mode );
+    cell_t sdFlushFile( FileStream * Stream  );
+    cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );
+    cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream  );
+    cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode );
+    off_t sdTellFile( FileStream * Stream );
+    cell_t sdCloseFile( FileStream * Stream );
+    cell_t sdInputChar( FileStream *stream );
+
+    #ifdef __cplusplus
+    }
+    #endif
+
+    #define  PF_SEEK_SET   (0)
+    #define  PF_SEEK_CUR   (1)
+    #define  PF_SEEK_END   (2)
+    /*
+    ** printf() is only used for debugging purposes.
+    ** It is not required for normal operation.
+    */
+    #define PRT(x) /* No printf(). */
+
+#else
+
+    #ifdef PF_USER_FILEIO
+/* Get user prototypes or macros from include file.
+** API must match that defined above for the stubs.
+*/
+        #include PF_USER_FILEIO
+
+    #else
+        typedef FILE FileStream;
+
+        #define sdOpenFile      fopen
+        #define sdDeleteFile      remove
+        #define sdFlushFile     fflush
+        #define sdReadFile      fread
+        #define sdWriteFile     fwrite
+        #if defined(WIN32) || defined(__NT__)
+            /* TODO To support 64-bit file offset we probably need fseeki64(). */
+            #define sdSeekFile      fseek
+            #define sdTellFile      ftell
+        #else
+            #define sdSeekFile      fseeko
+            #define sdTellFile      ftello
+        #endif
+        #define sdCloseFile     fclose
+        #define sdInputChar     fgetc
+
+        #define PF_STDIN  ((FileStream *) stdin)
+        #define PF_STDOUT ((FileStream *) stdout)
+
+        #define  PF_SEEK_SET   (0)
+        #define  PF_SEEK_CUR   (1)
+        #define  PF_SEEK_END   (2)
+
+        /*
+        ** printf() is only used for debugging purposes.
+        ** It is not required for normal operation.
+        */
+        #define PRT(x) { printf x; sdFlushFile(PF_STDOUT); }
+    #endif
+
+#endif  /* PF_NO_FILEIO */
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+cell_t ioAccept( char *Target, cell_t n1 );
+cell_t ioKey( void);
+void ioEmit( char c );
+void ioType( const char *s, cell_t n);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pf_io_h */

diff --git a/csrc/pf_io_none.c b/csrc/pf_io_none.c
index 0c4d1b3..feb14e5 100644 (file)
--- a/csrc/pf_io_none.c
+++ b/csrc/pf_io_none.c
@@ -1,49 +1,49 @@
-/* $Id$ */\r
-/***************************************************************\r
-** I/O subsystem for PForth when NO CHARACTER I/O is supported.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-\r
-#ifdef PF_NO_CHARIO\r
-int  sdTerminalOut( char c )\r
-{\r
-       TOUCH(c);\r
-       return 0;\r
-}\r
-int  sdTerminalEcho( char c )\r
-{\r
-       TOUCH(c);\r
-       return 0;\r
-}\r
-int  sdTerminalIn( void )\r
-{\r
-       return -1;\r
-}\r
-int  sdTerminalFlush( void )\r
-{\r
-       return -1;\r
-}\r
-void sdTerminalInit( void )\r
-{\r
-}\r
-void sdTerminalTerm( void )\r
-{\r
-}\r
-#endif\r
+/* $Id$ */
+/***************************************************************
+** I/O subsystem for PForth when NO CHARACTER I/O is supported.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+***************************************************************/
+
+#include "pf_all.h"
+
+
+#ifdef PF_NO_CHARIO
+int  sdTerminalOut( char c )
+{
+    TOUCH(c);
+    return 0;
+}
+int  sdTerminalEcho( char c )
+{
+    TOUCH(c);
+    return 0;
+}
+int  sdTerminalIn( void )
+{
+    return -1;
+}
+int  sdTerminalFlush( void )
+{
+    return -1;
+}
+void sdTerminalInit( void )
+{
+}
+void sdTerminalTerm( void )
+{
+}
+#endif

diff --git a/csrc/pf_main.c b/csrc/pf_main.c
index a973553..5783f0f 100644 (file)
--- a/csrc/pf_main.c
+++ b/csrc/pf_main.c
@@ -1,148 +1,148 @@
-/* @(#) pf_main.c 98/01/26 1.2 */\r
-/***************************************************************\r
-** Forth based on 'C'\r
-**\r
-** main() routine that demonstrates how to call PForth as\r
-** a module from 'C' based application.\r
-** Customize this as needed for your application.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#if (defined(PF_NO_STDIO) || defined(PF_EMBEDDED))\r
-       #define NULL  ((void *) 0)\r
-       #define ERR(msg) /* { printf msg; } */\r
-#else\r
-       #include <stdio.h>\r
-       #define ERR(msg) { printf msg; }\r
-#endif\r
-\r
-#include "pforth.h"\r
-\r
-#ifndef PF_DEFAULT_DICTIONARY\r
-#define PF_DEFAULT_DICTIONARY "pforth.dic"\r
-#endif\r
-\r
-#ifdef __MWERKS__\r
-       #include <console.h>\r
-       #include <sioux.h>\r
-#endif\r
-\r
-#ifndef TRUE\r
-#define TRUE (1)\r
-#define FALSE (0)\r
-#endif\r
-\r
-#ifdef PF_EMBEDDED\r
-int main( void )\r
-{\r
-    char IfInit = 0; \r
-    const char *DicName = NULL;\r
-    const char *SourceName = NULL;\r
-    pfMessage("\npForth Embedded\n");\r
-    return pfDoForth( DicName, SourceName, IfInit);\r
-}\r
-#else\r
-\r
-int main( int argc, char **argv )\r
-{\r
-#ifdef PF_STATIC_DIC\r
-       const char *DicName = NULL;\r
-#else /* PF_STATIC_DIC */\r
-       const char *DicName = PF_DEFAULT_DICTIONARY;\r
-#endif /* !PF_STATIC_DIC */\r
-\r
-       const char *SourceName = NULL;\r
-       char IfInit = FALSE;\r
-       char *s;\r
-       cell_t i;\r
-       int Result;\r
-\r
-/* For Metroworks on Mac */\r
-#ifdef __MWERKS__\r
-       argc = ccommand(&argv);\r
-#endif\r
-       \r
-       pfSetQuiet( FALSE );\r
-/* Parse command line. */\r
-       for( i=1; i<argc; i++ )\r
-       {\r
-               s = argv[i];\r
-\r
-               if( *s == '-' )\r
-               {\r
-                       char c;\r
-                       s++; /* past '-' */\r
-                       c = *s++;\r
-                       switch(c)\r
-                       {\r
-                       case 'i':\r
-                               IfInit = TRUE;\r
-                               DicName = NULL;\r
-                               break;\r
-                               \r
-                       case 'q':\r
-                               pfSetQuiet( TRUE );\r
-                               break;\r
-                               \r
-                       case 'd':\r
-                               if( *s != '\0' ) DicName = s;\r
-                               /* Allow space after -d (Thanks Aleksej Saushev) */\r
-                               /* Make sure there is another argument. */\r
-                               else if( (i+1) < argc )\r
-                               {\r
-                                       DicName = argv[++i];\r
-                               }\r
-                               if (DicName == NULL || *DicName == '\0')\r
-                               {\r
-                                       DicName = PF_DEFAULT_DICTIONARY;\r
-                               }\r
-                               break;\r
-                               \r
-                       default:\r
-                               ERR(("Unrecognized option!\n"));\r
-                               ERR(("pforth {-i} {-q} {-dfilename.dic} {sourcefilename}\n"));\r
-                               Result = 1;\r
-                               goto on_error;\r
-                               break;\r
-                       }\r
-               }\r
-               else\r
-               {\r
-                       SourceName = s;\r
-               }\r
-       }\r
-/* Force Init */\r
-#ifdef PF_INIT_MODE\r
-       IfInit = TRUE;\r
-       DicName = NULL;\r
-#endif\r
-\r
-#ifdef PF_UNIT_TEST\r
-       if( (Result = pfUnitTest()) != 0 )\r
-       {\r
-               ERR(("pForth stopping on unit test failure.\n"));\r
-               goto on_error;\r
-       }\r
-#endif\r
-       \r
-       Result = pfDoForth( DicName, SourceName, IfInit);\r
-\r
-on_error:\r
-       return Result;\r
-}\r
-\r
-#endif  /* PF_EMBEDDED */\r
-\r
-\r
+/* @(#) pf_main.c 98/01/26 1.2 */
+/***************************************************************
+** Forth based on 'C'
+**
+** main() routine that demonstrates how to call PForth as
+** a module from 'C' based application.
+** Customize this as needed for your application.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#if (defined(PF_NO_STDIO) || defined(PF_EMBEDDED))
+    #define NULL  ((void *) 0)
+    #define ERR(msg) /* { printf msg; } */
+#else
+    #include <stdio.h>
+    #define ERR(msg) { printf msg; }
+#endif
+
+#include "pforth.h"
+
+#ifndef PF_DEFAULT_DICTIONARY
+#define PF_DEFAULT_DICTIONARY "pforth.dic"
+#endif
+
+#ifdef __MWERKS__
+    #include <console.h>
+    #include <sioux.h>
+#endif
+
+#ifndef TRUE
+#define TRUE (1)
+#define FALSE (0)
+#endif
+
+#ifdef PF_EMBEDDED
+int main( void )
+{
+    char IfInit = 0;
+    const char *DicName = NULL;
+    const char *SourceName = NULL;
+    pfMessage("\npForth Embedded\n");
+    return pfDoForth( DicName, SourceName, IfInit);
+}
+#else
+
+int main( int argc, char **argv )
+{
+#ifdef PF_STATIC_DIC
+    const char *DicName = NULL;
+#else /* PF_STATIC_DIC */
+    const char *DicName = PF_DEFAULT_DICTIONARY;
+#endif /* !PF_STATIC_DIC */
+
+    const char *SourceName = NULL;
+    char IfInit = FALSE;
+    char *s;
+    cell_t i;
+    int Result;
+
+/* For Metroworks on Mac */
+#ifdef __MWERKS__
+    argc = ccommand(&argv);
+#endif
+
+    pfSetQuiet( FALSE );
+/* Parse command line. */
+    for( i=1; i<argc; i++ )
+    {
+        s = argv[i];
+
+        if( *s == '-' )
+        {
+            char c;
+            s++; /* past '-' */
+            c = *s++;
+            switch(c)
+            {
+            case 'i':
+                IfInit = TRUE;
+                DicName = NULL;
+                break;
+
+            case 'q':
+                pfSetQuiet( TRUE );
+                break;
+
+            case 'd':
+                if( *s != '\0' ) DicName = s;
+                /* Allow space after -d (Thanks Aleksej Saushev) */
+                /* Make sure there is another argument. */
+                else if( (i+1) < argc )
+                {
+                    DicName = argv[++i];
+                }
+                if (DicName == NULL || *DicName == '\0')
+                {
+                    DicName = PF_DEFAULT_DICTIONARY;
+                }
+                break;
+
+            default:
+                ERR(("Unrecognized option!\n"));
+                ERR(("pforth {-i} {-q} {-dfilename.dic} {sourcefilename}\n"));
+                Result = 1;
+                goto on_error;
+                break;
+            }
+        }
+        else
+        {
+            SourceName = s;
+        }
+    }
+/* Force Init */
+#ifdef PF_INIT_MODE
+    IfInit = TRUE;
+    DicName = NULL;
+#endif
+
+#ifdef PF_UNIT_TEST
+    if( (Result = pfUnitTest()) != 0 )
+    {
+        ERR(("pForth stopping on unit test failure.\n"));
+        goto on_error;
+    }
+#endif
+
+    Result = pfDoForth( DicName, SourceName, IfInit);
+
+on_error:
+    return Result;
+}
+
+#endif  /* PF_EMBEDDED */
+
+

diff --git a/csrc/pf_mem.c b/csrc/pf_mem.c
index 4cdd94d..8324601 100644 (file)
--- a/csrc/pf_mem.c
+++ b/csrc/pf_mem.c
@@ -1,366 +1,366 @@
-/***************************************************************\r
-** Memory allocator for systems that don't have real one.\r
-** This might be useful when bringing up a new computer with no OS.\r
-**\r
-** For PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-**\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-\r
-#ifdef PF_NO_MALLOC\r
-\r
-static char  *gMemPoolPtr;\r
-static ucell_t gMemPoolSize;\r
-\r
-/* CUSTOM: Make the memory pool bigger if you want. */\r
-#ifndef PF_MEM_POOL_SIZE\r
-       #define PF_MEM_POOL_SIZE (0x100000)\r
-#endif\r
-\r
-#define PF_MEM_BLOCK_SIZE (16)\r
-\r
-#ifndef PF_MALLOC_ADDRESS\r
-       static char MemoryPool[PF_MEM_POOL_SIZE];\r
-       #define PF_MALLOC_ADDRESS MemoryPool\r
-#endif\r
-\r
-/**********************************************************\r
-** Doubly Linked List Tools\r
-**********************************************************/\r
-\r
-typedef struct DoublyLinkedListNode_s\r
-{\r
-       struct DoublyLinkedListNode_s *dlln_Next;\r
-       struct DoublyLinkedListNode_s *dlln_Previous;\r
-} DoublyLinkedListNode;\r
-\r
-typedef struct DoublyLinkedList_s\r
-{\r
-       DoublyLinkedListNode *dll_First;\r
-       DoublyLinkedListNode *dll_Null;\r
-       DoublyLinkedListNode *dll_Last;\r
-} DoublyLinkedList;\r
-\r
-#define dllPreviousNode(n) ((n)->dlln_Previous)\r
-#define dllNextNode(n) ((n)->dlln_Next)\r
-\r
-void dllSetupList( DoublyLinkedList *dll )\r
-{\r
-       dll->dll_First = &(dll->dll_Null);\r
-       dll->dll_Null = (DoublyLinkedListNode *) NULL;\r
-       dll->dll_Last = &(dll->dll_First);\r
-}\r
-\r
-void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 )\r
-{\r
-       Node0->dlln_Next = Node1;\r
-       Node1->dlln_Previous = Node0;\r
-}\r
-\r
-void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr,\r
-       DoublyLinkedListNode *NodeInListPtr )\r
-{\r
-       DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr );\r
-       dllLinkNodes( NodePreviousPtr, NewNodePtr );\r
-       dllLinkNodes( NewNodePtr, NodeInListPtr );\r
-}\r
-\r
-void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr,\r
-       DoublyLinkedListNode *NodeInListPtr )\r
-{\r
-       DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr );\r
-       dllLinkNodes( NodeInListPtr, NewNodePtr );\r
-       dllLinkNodes( NewNodePtr, NodeNextPtr );\r
-}\r
-\r
-void dllDumpNode( DoublyLinkedListNode *NodePtr )\r
-{\r
-       TOUCH(NodePtr);\r
-       DBUG(("  0x%x -> (0x%x) -> 0x%x\n",\r
-               dllPreviousNode( NodePtr ), NodePtr,\r
-               dllNextNode( NodePtr ) ));\r
-}\r
-\r
-cell_t dllCheckNode( DoublyLinkedListNode *NodePtr )\r
-{\r
-       if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) ||\r
-           (NodePtr->dlln_Previous->dlln_Next != NodePtr))\r
-       {\r
-               ERR("dllCheckNode: Bad Node!\n");\r
-               dllDumpNode( dllPreviousNode( NodePtr ) );\r
-               dllDumpNode( NodePtr );\r
-               dllDumpNode( dllNextNode( NodePtr ) );\r
-               return -1;\r
-       }\r
-       else\r
-       {\r
-               return 0;\r
-       }\r
-}\r
-void dllRemoveNode( DoublyLinkedListNode *NodePtr )\r
-{\r
-       if( dllCheckNode( NodePtr ) == 0 )\r
-       {\r
-               dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) );\r
-       }\r
-}\r
-\r
-void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )\r
-{\r
-       dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First );\r
-}\r
-\r
-void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )\r
-{\r
-       dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last );\r
-}\r
-\r
-#define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) )\r
-#define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL )\r
-#define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) )\r
-#define dllFirstNode( l ) ((l)->dll_First)\r
-\r
-static DoublyLinkedList gMemList;\r
-\r
-typedef struct MemListNode\r
-{\r
-       DoublyLinkedListNode  mln_Node;\r
-       cell_t                 mln_Size;\r
-} MemListNode;\r
-\r
-#ifdef PF_DEBUG\r
-/***************************************************************\r
-** Dump memory list.\r
-*/\r
-void maDumpList( void )\r
-{\r
-       MemListNode *mln;\r
-       \r
-       MSG("PForth MemList\n");\r
-       \r
-       for( mln = (MemListNode *) dllFirstNode( &gMemList );\r
-            dllIsNodeInList( (DoublyLinkedListNode *) mln);\r
-                mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )\r
-       {\r
-               MSG("  Node at = 0x"); ffDotHex(mln);\r
-               MSG_NUM_H(", size = 0x", mln->mln_Size);\r
-       }\r
-}\r
-#endif\r
-\r
-\r
-/***************************************************************\r
-** Free mem of any size.\r
-*/\r
-static void pfFreeRawMem( char *Mem, cell_t NumBytes )\r
-{\r
-       MemListNode *mln, *FreeNode;\r
-       MemListNode *AdjacentLower = NULL;\r
-       MemListNode *AdjacentHigher = NULL;\r
-       MemListNode *NextBiggest = NULL;\r
-       \r
-/* Allocate in whole blocks of 16 bytes */\r
-       DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes ));\r
-       NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);\r
-       DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes ));\r
-       \r
-/* Check memory alignment. */\r
-       if( ( ((cell_t)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0)\r
-       {\r
-               MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (cell_t) Mem );\r
-               return;\r
-       }\r
-       \r
-/* Scan list from low to high looking for various nodes. */\r
-       for( mln = (MemListNode *) dllFirstNode( &gMemList );\r
-            dllIsNodeInList( (DoublyLinkedListNode *) mln);\r
-                mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )\r
-       {\r
-               if( (((char *) mln) + mln->mln_Size) == Mem )\r
-               {\r
-                       AdjacentLower = mln;\r
-               }\r
-               else if( ((char *) mln) == ( Mem + NumBytes ))\r
-               {\r
-                       AdjacentHigher = mln;\r
-               }\r
-/* is this the next biggest node. */\r
-               else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) )\r
-               {\r
-                       NextBiggest = mln;\r
-               }\r
-       }\r
-       \r
-/* Check to see if we can merge nodes. */\r
-       if( AdjacentHigher )\r
-       {\r
-DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher ));\r
-               NumBytes += AdjacentHigher->mln_Size;\r
-               dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher );\r
-       }\r
-       if( AdjacentLower )\r
-       {\r
-DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem ));\r
-               AdjacentLower->mln_Size += NumBytes;\r
-       }\r
-       else\r
-       {\r
-DBUG((" Link before 0x%x\n", NextBiggest ));\r
-               FreeNode = (MemListNode *) Mem;\r
-               FreeNode->mln_Size = NumBytes;\r
-               if( NextBiggest == NULL )\r
-               {\r
-/* Nothing bigger so add to end of list. */\r
-                       dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode );\r
-               }\r
-               else\r
-               {\r
-/* Add this node before the next biggest one we found. */\r
-                       dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode,\r
-                               (DoublyLinkedListNode *) NextBiggest );\r
-               }\r
-       }\r
-       \r
-/*     maDumpList(); */\r
-}\r
-\r
-\r
-\r
-/***************************************************************\r
-** Setup memory list. Initialize allocator.\r
-*/\r
-static void pfInitMemBlock( void *addr, ucell_t poolSize )\r
-{\r
-       char *AlignedMemory;\r
-       cell_t AlignedSize;\r
-\r
-       pfDebugMessage("pfInitMemBlock()\n");\r
-/* Set globals. */\r
-       gMemPoolPtr = addr;\r
-       gMemPoolSize = poolSize;\r
-       \r
-       dllSetupList( &gMemList );\r
-       \r
-/* Adjust to next highest aligned memory location. */\r
-       AlignedMemory = (char *) ((((cell_t)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) &\r
-                         ~(PF_MEM_BLOCK_SIZE - 1));\r
-                                         \r
-/* Adjust size to reflect aligned memory. */\r
-       AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr);\r
-       \r
-/* Align size of pool. */\r
-       AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1);\r
-       \r
-/* Free to pool. */\r
-       pfFreeRawMem( AlignedMemory, AlignedSize );\r
-       \r
-}\r
-\r
-/***************************************************************\r
-** Allocate mem from list of free nodes.\r
-*/\r
-static char *pfAllocRawMem( cell_t NumBytes )\r
-{\r
-       char *Mem = NULL;\r
-       MemListNode *mln;\r
-       pfDebugMessage("pfAllocRawMem()\n");\r
-       \r
-       if( NumBytes <= 0 ) return NULL;\r
-       \r
-/* Allocate in whole blocks of 16 bytes */\r
-       NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);\r
-       \r
-       DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes ));\r
-       \r
-/* Scan list from low to high until we find a node big enough. */\r
-       for( mln = (MemListNode *) dllFirstNode( &gMemList );\r
-            dllIsNodeInList( (DoublyLinkedListNode *) mln);\r
-                mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )\r
-       {\r
-               if( mln->mln_Size >= NumBytes )\r
-               {\r
-                       cell_t RemSize;\r
-\r
-                       Mem = (char *) mln;\r
-                       \r
-/* Remove this node from list. */\r
-                       dllRemoveNode( (DoublyLinkedListNode *) mln );\r
-                       \r
-/* Is there enough left in block to make it worth splitting? */\r
-                       RemSize = mln->mln_Size - NumBytes;\r
-                       if( RemSize >= PF_MEM_BLOCK_SIZE )\r
-                       {\r
-                               pfFreeRawMem( (Mem + NumBytes), RemSize );\r
-                       }\r
-                       break;\r
-               }\r
-                               \r
-       }\r
-/*     maDumpList(); */\r
-       DBUG(("Allocate mem at 0x%x.\n", Mem ));\r
-       return Mem;\r
-}\r
-\r
-/***************************************************************\r
-** Keep mem size at first cell.\r
-*/\r
-char *pfAllocMem( cell_t NumBytes )\r
-{\r
-       cell_t *IntMem;\r
-       \r
-       if( NumBytes <= 0 ) return NULL;\r
-       \r
-/* Allocate an extra cell for size. */\r
-       NumBytes += sizeof(cell_t);\r
-       \r
-       IntMem = (cell_t *)pfAllocRawMem( NumBytes );\r
-       \r
-       if( IntMem != NULL ) *IntMem++ = NumBytes;\r
-       \r
-       return (char *) IntMem;\r
-}\r
-\r
-/***************************************************************\r
-** Free mem with mem size at first cell.\r
-*/\r
-void pfFreeMem( void *Mem )\r
-{\r
-       cell_t *IntMem;\r
-       cell_t NumBytes;\r
-       \r
-       if( Mem == NULL ) return;\r
-       \r
-/* Allocate an extra cell for size. */\r
-       IntMem = (cell_t *) Mem;\r
-       IntMem--;\r
-       NumBytes = *IntMem;\r
-       \r
-       pfFreeRawMem( (char *) IntMem, NumBytes );\r
-       \r
-}\r
-\r
-void pfInitMemoryAllocator( void )\r
-{\r
-       pfInitMemBlock( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE );\r
-}\r
-#else /* PF_NO_MALLOC */\r
-\r
-int not_an_empty_file;  /* Stops nasty compiler warnings when PF_NO_MALLOC not defined. */\r
-\r
-#endif /* PF_NO_MALLOC */\r
+/***************************************************************
+** Memory allocator for systems that don't have real one.
+** This might be useful when bringing up a new computer with no OS.
+**
+** For PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+**
+***************************************************************/
+
+#include "pf_all.h"
+
+
+#ifdef PF_NO_MALLOC
+
+static char  *gMemPoolPtr;
+static ucell_t gMemPoolSize;
+
+/* CUSTOM: Make the memory pool bigger if you want. */
+#ifndef PF_MEM_POOL_SIZE
+    #define PF_MEM_POOL_SIZE (0x100000)
+#endif
+
+#define PF_MEM_BLOCK_SIZE (16)
+
+#ifndef PF_MALLOC_ADDRESS
+    static char MemoryPool[PF_MEM_POOL_SIZE];
+    #define PF_MALLOC_ADDRESS MemoryPool
+#endif
+
+/**********************************************************
+** Doubly Linked List Tools
+**********************************************************/
+
+typedef struct DoublyLinkedListNode_s
+{
+    struct DoublyLinkedListNode_s *dlln_Next;
+    struct DoublyLinkedListNode_s *dlln_Previous;
+} DoublyLinkedListNode;
+
+typedef struct DoublyLinkedList_s
+{
+    DoublyLinkedListNode *dll_First;
+    DoublyLinkedListNode *dll_Null;
+    DoublyLinkedListNode *dll_Last;
+} DoublyLinkedList;
+
+#define dllPreviousNode(n) ((n)->dlln_Previous)
+#define dllNextNode(n) ((n)->dlln_Next)
+
+void dllSetupList( DoublyLinkedList *dll )
+{
+    dll->dll_First = &(dll->dll_Null);
+    dll->dll_Null = (DoublyLinkedListNode *) NULL;
+    dll->dll_Last = &(dll->dll_First);
+}
+
+void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 )
+{
+    Node0->dlln_Next = Node1;
+    Node1->dlln_Previous = Node0;
+}
+
+void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr,
+    DoublyLinkedListNode *NodeInListPtr )
+{
+    DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr );
+    dllLinkNodes( NodePreviousPtr, NewNodePtr );
+    dllLinkNodes( NewNodePtr, NodeInListPtr );
+}
+
+void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr,
+    DoublyLinkedListNode *NodeInListPtr )
+{
+    DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr );
+    dllLinkNodes( NodeInListPtr, NewNodePtr );
+    dllLinkNodes( NewNodePtr, NodeNextPtr );
+}
+
+void dllDumpNode( DoublyLinkedListNode *NodePtr )
+{
+    TOUCH(NodePtr);
+    DBUG(("  0x%x -> (0x%x) -> 0x%x\n",
+        dllPreviousNode( NodePtr ), NodePtr,
+        dllNextNode( NodePtr ) ));
+}
+
+cell_t dllCheckNode( DoublyLinkedListNode *NodePtr )
+{
+    if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) ||
+        (NodePtr->dlln_Previous->dlln_Next != NodePtr))
+    {
+        ERR("dllCheckNode: Bad Node!\n");
+        dllDumpNode( dllPreviousNode( NodePtr ) );
+        dllDumpNode( NodePtr );
+        dllDumpNode( dllNextNode( NodePtr ) );
+        return -1;
+    }
+    else
+    {
+        return 0;
+    }
+}
+void dllRemoveNode( DoublyLinkedListNode *NodePtr )
+{
+    if( dllCheckNode( NodePtr ) == 0 )
+    {
+        dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) );
+    }
+}
+
+void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )
+{
+    dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First );
+}
+
+void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )
+{
+    dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last );
+}
+
+#define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) )
+#define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL )
+#define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) )
+#define dllFirstNode( l ) ((l)->dll_First)
+
+static DoublyLinkedList gMemList;
+
+typedef struct MemListNode
+{
+    DoublyLinkedListNode  mln_Node;
+    cell_t                 mln_Size;
+} MemListNode;
+
+#ifdef PF_DEBUG
+/***************************************************************
+** Dump memory list.
+*/
+void maDumpList( void )
+{
+    MemListNode *mln;
+
+    MSG("PForth MemList\n");
+
+    for( mln = (MemListNode *) dllFirstNode( &gMemList );
+         dllIsNodeInList( (DoublyLinkedListNode *) mln);
+         mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
+    {
+        MSG("  Node at = 0x"); ffDotHex(mln);
+        MSG_NUM_H(", size = 0x", mln->mln_Size);
+    }
+}
+#endif
+
+
+/***************************************************************
+** Free mem of any size.
+*/
+static void pfFreeRawMem( char *Mem, cell_t NumBytes )
+{
+    MemListNode *mln, *FreeNode;
+    MemListNode *AdjacentLower = NULL;
+    MemListNode *AdjacentHigher = NULL;
+    MemListNode *NextBiggest = NULL;
+
+/* Allocate in whole blocks of 16 bytes */
+    DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes ));
+    NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);
+    DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes ));
+
+/* Check memory alignment. */
+    if( ( ((cell_t)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0)
+    {
+        MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (cell_t) Mem );
+        return;
+    }
+
+/* Scan list from low to high looking for various nodes. */
+    for( mln = (MemListNode *) dllFirstNode( &gMemList );
+         dllIsNodeInList( (DoublyLinkedListNode *) mln);
+         mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
+    {
+        if( (((char *) mln) + mln->mln_Size) == Mem )
+        {
+            AdjacentLower = mln;
+        }
+        else if( ((char *) mln) == ( Mem + NumBytes ))
+        {
+            AdjacentHigher = mln;
+        }
+/* is this the next biggest node. */
+        else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) )
+        {
+            NextBiggest = mln;
+        }
+    }
+
+/* Check to see if we can merge nodes. */
+    if( AdjacentHigher )
+    {
+DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher ));
+        NumBytes += AdjacentHigher->mln_Size;
+        dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher );
+    }
+    if( AdjacentLower )
+    {
+DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem ));
+        AdjacentLower->mln_Size += NumBytes;
+    }
+    else
+    {
+DBUG((" Link before 0x%x\n", NextBiggest ));
+        FreeNode = (MemListNode *) Mem;
+        FreeNode->mln_Size = NumBytes;
+        if( NextBiggest == NULL )
+        {
+/* Nothing bigger so add to end of list. */
+            dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode );
+        }
+        else
+        {
+/* Add this node before the next biggest one we found. */
+            dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode,
+                (DoublyLinkedListNode *) NextBiggest );
+        }
+    }
+
+/*  maDumpList(); */
+}
+
+
+
+/***************************************************************
+** Setup memory list. Initialize allocator.
+*/
+static void pfInitMemBlock( void *addr, ucell_t poolSize )
+{
+    char *AlignedMemory;
+    cell_t AlignedSize;
+
+    pfDebugMessage("pfInitMemBlock()\n");
+/* Set globals. */
+    gMemPoolPtr = addr;
+    gMemPoolSize = poolSize;
+
+    dllSetupList( &gMemList );
+
+/* Adjust to next highest aligned memory location. */
+    AlignedMemory = (char *) ((((cell_t)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) &
+                      ~(PF_MEM_BLOCK_SIZE - 1));
+
+/* Adjust size to reflect aligned memory. */
+    AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr);
+
+/* Align size of pool. */
+    AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1);
+
+/* Free to pool. */
+    pfFreeRawMem( AlignedMemory, AlignedSize );
+
+}
+
+/***************************************************************
+** Allocate mem from list of free nodes.
+*/
+static char *pfAllocRawMem( cell_t NumBytes )
+{
+    char *Mem = NULL;
+    MemListNode *mln;
+    pfDebugMessage("pfAllocRawMem()\n");
+
+    if( NumBytes <= 0 ) return NULL;
+
+/* Allocate in whole blocks of 16 bytes */
+    NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);
+
+    DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes ));
+
+/* Scan list from low to high until we find a node big enough. */
+    for( mln = (MemListNode *) dllFirstNode( &gMemList );
+         dllIsNodeInList( (DoublyLinkedListNode *) mln);
+         mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
+    {
+        if( mln->mln_Size >= NumBytes )
+        {
+            cell_t RemSize;
+
+            Mem = (char *) mln;
+
+/* Remove this node from list. */
+            dllRemoveNode( (DoublyLinkedListNode *) mln );
+
+/* Is there enough left in block to make it worth splitting? */
+            RemSize = mln->mln_Size - NumBytes;
+            if( RemSize >= PF_MEM_BLOCK_SIZE )
+            {
+                pfFreeRawMem( (Mem + NumBytes), RemSize );
+            }
+            break;
+        }
+
+    }
+/*  maDumpList(); */
+    DBUG(("Allocate mem at 0x%x.\n", Mem ));
+    return Mem;
+}
+
+/***************************************************************
+** Keep mem size at first cell.
+*/
+char *pfAllocMem( cell_t NumBytes )
+{
+    cell_t *IntMem;
+
+    if( NumBytes <= 0 ) return NULL;
+
+/* Allocate an extra cell for size. */
+    NumBytes += sizeof(cell_t);
+
+    IntMem = (cell_t *)pfAllocRawMem( NumBytes );
+
+    if( IntMem != NULL ) *IntMem++ = NumBytes;
+
+    return (char *) IntMem;
+}
+
+/***************************************************************
+** Free mem with mem size at first cell.
+*/
+void pfFreeMem( void *Mem )
+{
+    cell_t *IntMem;
+    cell_t NumBytes;
+
+    if( Mem == NULL ) return;
+
+/* Allocate an extra cell for size. */
+    IntMem = (cell_t *) Mem;
+    IntMem--;
+    NumBytes = *IntMem;
+
+    pfFreeRawMem( (char *) IntMem, NumBytes );
+
+}
+
+void pfInitMemoryAllocator( void )
+{
+    pfInitMemBlock( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE );
+}
+#else /* PF_NO_MALLOC */
+
+int not_an_empty_file;  /* Stops nasty compiler warnings when PF_NO_MALLOC not defined. */
+
+#endif /* PF_NO_MALLOC */

diff --git a/csrc/pf_mem.h b/csrc/pf_mem.h
index 9f8beda..24b7e17 100644 (file)
--- a/csrc/pf_mem.h
+++ b/csrc/pf_mem.h
@@ -1,47 +1,47 @@
-/* @(#) pf_mem.h 98/01/26 1.3 */\r
-#ifndef _pf_mem_h\r
-#define _pf_mem_h\r
-\r
-/***************************************************************\r
-** Include file for PForth Fake Memory Allocator\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-***************************************************************/\r
-\r
-#ifdef PF_NO_MALLOC\r
-\r
-       #ifdef __cplusplus\r
-       extern "C" {\r
-       #endif\r
-\r
-       void  pfInitMemoryAllocator( void );\r
-       char *pfAllocMem( cell_t NumBytes );\r
-       void  pfFreeMem( void *Mem );\r
-\r
-       #ifdef __cplusplus\r
-       }   \r
-       #endif\r
-\r
-#else\r
-\r
-       #ifdef PF_USER_MALLOC\r
-/* Get user prototypes or macros from include file.\r
-** API must match that defined above for the stubs.\r
-*/\r
-               #include PF_USER_MALLOC\r
-       #else\r
-               #define pfInitMemoryAllocator()\r
-               #define pfAllocMem malloc\r
-               #define pfFreeMem free\r
-       #endif\r
-       \r
-#endif /* PF_NO_MALLOC */\r
-\r
-#endif /* _pf_mem_h */\r
+/* @(#) pf_mem.h 98/01/26 1.3 */
+#ifndef _pf_mem_h
+#define _pf_mem_h
+
+/***************************************************************
+** Include file for PForth Fake Memory Allocator
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** code is provided on an "as is" basis without any warranty
+** of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular
+***************************************************************/
+
+#ifdef PF_NO_MALLOC
+
+    #ifdef __cplusplus
+    extern "C" {
+    #endif
+
+    void  pfInitMemoryAllocator( void );
+    char *pfAllocMem( cell_t NumBytes );
+    void  pfFreeMem( void *Mem );
+
+    #ifdef __cplusplus
+    }
+    #endif
+
+#else
+
+    #ifdef PF_USER_MALLOC
+/* Get user prototypes or macros from include file.
+** API must match that defined above for the stubs.
+*/
+        #include PF_USER_MALLOC
+    #else
+        #define pfInitMemoryAllocator()
+        #define pfAllocMem malloc
+        #define pfFreeMem free
+    #endif
+
+#endif /* PF_NO_MALLOC */
+
+#endif /* _pf_mem_h */

diff --git a/csrc/pf_save.c b/csrc/pf_save.c
index 80b4c1e..2baf297 100644 (file)
--- a/csrc/pf_save.c
+++ b/csrc/pf_save.c
@@ -1,844 +1,844 @@
-/* @(#) pf_save.c 98/01/26 1.3 */\r
-/***************************************************************\r
-** Save and Load Dictionary\r
-** for PForth based on 'C'\r
-**\r
-** Compile file based version or static data based version\r
-** depending on PF_NO_FILEIO switch.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 940225 PLB Fixed CodePtr save, was using NAMEREL instead of CODEREL\r
-**            This would only work if the relative location\r
-**            of names and code was the same when saved and reloaded.\r
-** 940228 PLB Added PF_NO_FILEIO version\r
-** 961204 PLB Added PF_STATIC_DIC\r
-** 000623 PLB Cast chars as ucell_t before shifting for 16 bit systems.\r
-***************************************************************/\r
-\r
-#include <assert.h>\r
-\r
-#include "pf_all.h"\r
-\r
-/* If no File I/O, then force static dictionary. */\r
-#ifdef PF_NO_FILEIO\r
-       #ifndef PF_STATIC_DIC\r
-               #define PF_STATIC_DIC\r
-       #endif\r
-#endif\r
-\r
-#ifdef PF_STATIC_DIC\r
-       #include "pfdicdat.h"\r
-#endif\r
-\r
-/*\r
-Dictionary File Format based on IFF standard.\r
-The chunk IDs, sizes, and data values are all Big Endian in conformance with the IFF standard.\r
-The dictionaries may be big or little endian.\r
-       'FORM'\r
-       size\r
-       'P4TH'  -  Form Identifier\r
-\r
-Chunks\r
-       'P4DI'\r
-       size\r
-       struct DictionaryInfoChunk\r
-\r
-       'P4NM'\r
-       size\r
-       Name and Header portion of dictionary. (Big or Little Endian) (Optional)\r
-\r
-       'P4CD'\r
-       size\r
-       Code portion of dictionary. (Big or Little Endian) \r
-*/\r
-\r
-\r
-/***************************************************************/\r
-/* Endian-ness tools. */\r
-ucell_t ReadCellBigEndian( const uint8_t *addr )\r
-{\r
-       ucell_t temp = (ucell_t)addr[0];\r
-       temp = (temp << 8) | ((ucell_t)addr[1]);\r
-       temp = (temp << 8) | ((ucell_t)addr[2]);\r
-       temp = (temp << 8) | ((ucell_t)addr[3]);\r
-       if( sizeof(ucell_t) == 8 )\r
-       {\r
-               temp = (temp << 8) | ((ucell_t)addr[4]);\r
-               temp = (temp << 8) | ((ucell_t)addr[5]);\r
-               temp = (temp << 8) | ((ucell_t)addr[6]);\r
-               temp = (temp << 8) | ((ucell_t)addr[7]);\r
-       }\r
-               \r
-       return temp;\r
-}\r
-/***************************************************************/\r
-/* Endian-ness tools. */\r
-uint32_t Read32BigEndian( const uint8_t *addr )\r
-{\r
-       uint32_t temp = (uint32_t)addr[0];\r
-       temp = (temp << 8) | ((uint32_t)addr[1]);\r
-       temp = (temp << 8) | ((uint32_t)addr[2]);\r
-       temp = (temp << 8) | ((uint32_t)addr[3]);\r
-       return temp;\r
-}\r
-\r
-/***************************************************************/\r
-uint16_t Read16BigEndian( const uint8_t *addr )\r
-{\r
-       return (uint16_t) ((addr[0]<<8) | addr[1]);\r
-}\r
-\r
-/***************************************************************/\r
-ucell_t ReadCellLittleEndian( const uint8_t *addr )\r
-{\r
-       ucell_t temp = 0;\r
-       if( sizeof(ucell_t) == 8 )\r
-       {\r
-               temp = (temp << 8) | ((uint32_t)addr[7]);\r
-               temp = (temp << 8) | ((uint32_t)addr[6]);\r
-               temp = (temp << 8) | ((uint32_t)addr[5]);\r
-               temp = (temp << 8) | ((uint32_t)addr[4]);\r
-       }\r
-       temp = (temp << 8) | ((uint32_t)addr[3]);\r
-       temp = (temp << 8) | ((uint32_t)addr[2]);\r
-       temp = (temp << 8) | ((uint32_t)addr[1]);\r
-       temp = (temp << 8) | ((uint32_t)addr[0]);\r
-       return temp;\r
-}\r
-\r
-/***************************************************************/\r
-uint32_t Read32LittleEndian( const uint8_t *addr )\r
-{\r
-       uint32_t temp = (uint32_t)addr[3];\r
-       temp = (temp << 8) | ((uint32_t)addr[2]);\r
-       temp = (temp << 8) | ((uint32_t)addr[1]);\r
-       temp = (temp << 8) | ((uint32_t)addr[0]);\r
-       return temp;\r
-}\r
-\r
-/***************************************************************/\r
-uint16_t Read16LittleEndian( const uint8_t *addr )\r
-{\r
-       const unsigned char *bp = (const unsigned char *) addr;\r
-       return (uint16_t) ((bp[1]<<8) | bp[0]);\r
-}\r
-\r
-#ifdef PF_SUPPORT_FP\r
-\r
-/***************************************************************/\r
-static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst );\r
-\r
-static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst )\r
-{\r
-       int i;\r
-       unsigned char *d = (unsigned char *) dst;\r
-       const unsigned char *s = (const unsigned char *) src;\r
-\r
-       for( i=0; i<sizeof(PF_FLOAT); i++ )\r
-       {\r
-               d[i] = s[sizeof(PF_FLOAT) - 1 - i];\r
-       }\r
-}\r
-\r
-/***************************************************************/\r
-void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data )\r
-{\r
-       if( IsHostLittleEndian() )\r
-       {\r
-               ReverseCopyFloat( &data, addr );\r
-       }\r
-       else\r
-       {\r
-               *addr = data;\r
-       }\r
-}\r
-\r
-/***************************************************************/\r
-PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr )\r
-{\r
-       PF_FLOAT data;\r
-       if( IsHostLittleEndian() )\r
-       {\r
-               ReverseCopyFloat( addr, &data );\r
-               return data;\r
-       }\r
-       else\r
-       {\r
-               return *addr;\r
-       }\r
-}\r
-\r
-/***************************************************************/\r
-void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data )\r
-{\r
-       if( IsHostLittleEndian() )\r
-       {\r
-               *addr = data;\r
-       }\r
-       else\r
-       {\r
-               ReverseCopyFloat( &data, addr );\r
-       }\r
-}\r
-\r
-/***************************************************************/\r
-PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr )\r
-{\r
-       PF_FLOAT data;\r
-       if( IsHostLittleEndian() )\r
-       {\r
-               return *addr;\r
-       }\r
-       else\r
-       {\r
-               ReverseCopyFloat( addr, &data );\r
-               return data;\r
-       }\r
-}\r
-\r
-#endif /* PF_SUPPORT_FP */\r
-\r
-/***************************************************************/\r
-void WriteCellBigEndian( uint8_t *addr, ucell_t data )\r
-{\r
-       /* Write should be in order of increasing address \r
-        * to optimize for burst writes to DRAM. */\r
-       if( sizeof(ucell_t) == 8 )\r
-       {\r
-               *addr++ = (uint8_t) (data>>56);\r
-               *addr++ = (uint8_t) (data>>48);\r
-               *addr++ = (uint8_t) (data>>40);\r
-               *addr++ = (uint8_t) (data>>32);\r
-       }\r
-       *addr++ = (uint8_t) (data>>24);\r
-       *addr++ = (uint8_t) (data>>16);\r
-       *addr++ = (uint8_t) (data>>8);\r
-       *addr = (uint8_t) (data);\r
-}\r
-\r
-/***************************************************************/\r
-void Write32BigEndian( uint8_t *addr, uint32_t data )\r
-{\r
-       *addr++ = (uint8_t) (data>>24);\r
-       *addr++ = (uint8_t) (data>>16);\r
-       *addr++ = (uint8_t) (data>>8);\r
-       *addr = (uint8_t) (data);\r
-}\r
-\r
-/***************************************************************/\r
-void Write16BigEndian( uint8_t *addr, uint16_t data )\r
-{\r
-       *addr++ = (uint8_t) (data>>8);\r
-       *addr = (uint8_t) (data);\r
-}\r
-\r
-/***************************************************************/\r
-void WriteCellLittleEndian( uint8_t *addr, ucell_t data )\r
-{\r
-       /* Write should be in order of increasing address \r
-        * to optimize for burst writes to DRAM. */\r
-       if( sizeof(ucell_t) == 8 )\r
-       {\r
-               *addr++ = (uint8_t) data;  /* LSB at near end */\r
-               data = data >> 8;\r
-               *addr++ = (uint8_t) data;\r
-               data = data >> 8;\r
-               *addr++ = (uint8_t) data;\r
-               data = data >> 8;\r
-               *addr++ = (uint8_t) data;\r
-               data = data >> 8;\r
-       }\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr = (uint8_t) data;\r
-}\r
-/***************************************************************/\r
-void Write32LittleEndian( uint8_t *addr, uint32_t data )\r
-{\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr = (uint8_t) data;\r
-}\r
-\r
-/***************************************************************/\r
-void Write16LittleEndian( uint8_t *addr, uint16_t data )\r
-{\r
-       *addr++ = (uint8_t) data;\r
-       data = data >> 8;\r
-       *addr = (uint8_t) data;\r
-}\r
-\r
-/***************************************************************/\r
-/* Return 1 if host CPU is Little Endian */\r
-int IsHostLittleEndian( void )\r
-{\r
-    static int gEndianCheck = 1;\r
-       unsigned char *bp = (unsigned char *) &gEndianCheck;\r
-       return (int) (*bp); /* Return byte pointed to by address. If LSB then == 1 */\r
-}\r
-\r
-#if defined(PF_NO_FILEIO) || defined(PF_NO_SHELL)\r
-\r
-cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)\r
-{\r
-       TOUCH(FileName);\r
-       TOUCH(EntryPoint);\r
-       TOUCH(NameSize);\r
-       TOUCH(CodeSize);\r
-\r
-       pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED);\r
-       return -1;\r
-}\r
-\r
-#else /* PF_NO_FILEIO or PF_NO_SHELL */\r
-\r
-/***************************************************************/\r
-static int Write32ToFile( FileStream *fid, uint32_t Val )\r
-{\r
-       int numw;\r
-       uint8_t pad[4];\r
-\r
-       Write32BigEndian(pad,Val);\r
-       numw = sdWriteFile( pad, 1, sizeof(pad), fid );\r
-       if( numw != sizeof(pad) ) return -1;\r
-       return 0;\r
-}\r
-\r
-/***************************************************************/\r
-static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t NumBytes )\r
-{\r
-       cell_t numw;\r
-       cell_t EvenNumW;\r
-\r
-       EvenNumW = EVENUP(NumBytes);\r
-\r
-       if( Write32ToFile( fid, ID ) < 0 ) goto error;\r
-       if( Write32ToFile( fid, EvenNumW ) < 0 ) goto error;\r
-\r
-       numw = sdWriteFile( Data, 1, EvenNumW, fid );\r
-       if( numw != EvenNumW ) goto error;\r
-       return 0;\r
-error:\r
-       pfReportError("WriteChunkToFile", PF_ERR_WRITE_FILE);\r
-       return -1;\r
-}\r
-\r
-/* Convert dictionary info chunk between native and on-disk (big-endian). */\r
-static void\r
-convertDictionaryInfoWrite (DictionaryInfoChunk *sd)\r
-{\r
-/* Convert all fields in DictionaryInfoChunk from Native to BigEndian. \r
- * This assumes they are all 32-bit integers.\r
- */\r
-       int   i;\r
-       uint32_t *p = (uint32_t *) sd;\r
-       for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)\r
-       {\r
-               Write32BigEndian( (uint8_t *)&p[i], p[i] );\r
-       }\r
-}\r
-\r
-static void\r
-convertDictionaryInfoRead (DictionaryInfoChunk *sd)\r
-{\r
-/* Convert all fields in structure from BigEndian to Native. */\r
-       int   i;\r
-       uint32_t *p = (uint32_t *) sd;\r
-       for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)\r
-       {\r
-               p[i] = Read32BigEndian( (uint8_t *)&p[i] );\r
-       }\r
-}\r
-\r
-/****************************************************************\r
-** Save Dictionary in File.\r
-** If EntryPoint is NULL, save as development environment.\r
-** If EntryPoint is non-NULL, save as turnKey environment with no names.\r
-*/\r
-cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)\r
-{\r
-       FileStream *fid;\r
-       DictionaryInfoChunk SD;\r
-       uint32_t FormSize;\r
-       uint32_t NameChunkSize = 0;\r
-       uint32_t CodeChunkSize;\r
-       uint32_t relativeCodePtr;\r
-\r
-       fid = sdOpenFile( FileName, "wb" );\r
-       if( fid == NULL )\r
-       {\r
-               pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE);\r
-               return -1;\r
-       }\r
-\r
-/* Save in uninitialized form. */\r
-       pfExecIfDefined("AUTO.TERM");\r
-\r
-/* Write FORM Header ---------------------------- */\r
-       if( Write32ToFile( fid, ID_FORM ) < 0 ) goto error;\r
-       if( Write32ToFile( fid, 0 ) < 0 ) goto error;\r
-       if( Write32ToFile( fid, ID_P4TH ) < 0 ) goto error;\r
-\r
-/* Write P4DI Dictionary Info  ------------------ */\r
-       SD.sd_Version = PF_FILE_VERSION;\r
-\r
-       relativeCodePtr = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */\r
-       SD.sd_RelCodePtr = relativeCodePtr; \r
-       SD.sd_UserStackSize = sizeof(cell_t) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit);\r
-       SD.sd_ReturnStackSize = sizeof(cell_t) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit);\r
-       SD.sd_NumPrimitives = gNumPrimitives;  /* Must match compiled dictionary. */\r
-\r
-#ifdef PF_SUPPORT_FP\r
-       SD.sd_FloatSize = sizeof(PF_FLOAT);  /* Must match compiled dictionary. */\r
-#else\r
-       SD.sd_FloatSize = 0;\r
-#endif\r
-\r
-       SD.sd_CellSize = sizeof(cell_t);\r
-\r
-/* Set bit that specifies whether dictionary is BIG or LITTLE Endian. */\r
-       {\r
-#if defined(PF_BIG_ENDIAN_DIC)\r
-               int eflag = SD_F_BIG_ENDIAN_DIC;\r
-#elif defined(PF_LITTLE_ENDIAN_DIC)\r
-               int eflag = 0;\r
-#else\r
-               int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC;\r
-#endif\r
-               SD.sd_Flags = eflag;\r
-       }\r
-\r
-       if( EntryPoint )\r
-       {\r
-               SD.sd_EntryPoint = EntryPoint;  /* Turnkey! */\r
-       }\r
-       else\r
-       {\r
-               SD.sd_EntryPoint = 0;\r
-       }\r
-\r
-/* Do we save names? */\r
-       if( NameSize == 0 )\r
-       {\r
-               SD.sd_RelContext = 0;\r
-               SD.sd_RelHeaderPtr = 0;\r
-               SD.sd_NameSize = 0;\r
-       }\r
-       else\r
-       {\r
-               uint32_t relativeHeaderPtr;\r
-/* Development mode. */\r
-               SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext);\r
-               relativeHeaderPtr = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr);\r
-               SD.sd_RelHeaderPtr = relativeHeaderPtr;\r
-\r
-/* How much real name space is there? */\r
-               NameChunkSize = QUADUP(relativeHeaderPtr);  /* Align */\r
-\r
-/* NameSize must be 0 or greater than NameChunkSize + 1K */\r
-               NameSize = QUADUP(NameSize);  /* Align */\r
-               if( NameSize > 0 )\r
-               {\r
-                       NameSize = MAX( NameSize, (NameChunkSize + 1024) );\r
-               }\r
-               SD.sd_NameSize = NameSize;\r
-       }\r
-\r
-/* How much real code is there? */\r
-       CodeChunkSize = QUADUP(relativeCodePtr);\r
-       CodeSize = QUADUP(CodeSize);  /* Align */\r
-       CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) );\r
-       SD.sd_CodeSize = CodeSize;\r
-\r
-       \r
-       convertDictionaryInfoWrite (&SD);\r
-\r
-       if( WriteChunkToFile( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error;\r
-\r
-/* Write Name Fields if NameSize non-zero ------- */\r
-       if( NameSize > 0 )\r
-       {\r
-               if( WriteChunkToFile( fid, ID_P4NM, (char *) NAME_BASE,\r
-                       NameChunkSize ) < 0 ) goto error;\r
-       }\r
-\r
-/* Write Code Fields ---------------------------- */\r
-       if( WriteChunkToFile( fid, ID_P4CD, (char *) CODE_BASE,\r
-               CodeChunkSize ) < 0 ) goto error;\r
-\r
-       FormSize = sdTellFile( fid ) - 8;\r
-       sdSeekFile( fid, 4, PF_SEEK_SET );\r
-       if( Write32ToFile( fid, FormSize ) < 0 ) goto error;\r
-\r
-       sdCloseFile( fid );\r
-\r
-/* Restore initialization. */\r
-       pfExecIfDefined("AUTO.INIT");\r
-       return 0;\r
-\r
-error:\r
-       sdSeekFile( fid, 0, PF_SEEK_SET );\r
-       Write32ToFile( fid, ID_BADF ); /* Mark file as bad. */\r
-       sdCloseFile( fid );\r
-\r
-/* Restore initialization. */\r
-       pfExecIfDefined("AUTO.INIT");\r
-\r
-       return -1;\r
-}\r
-\r
-#endif /* !PF_NO_FILEIO and !PF_NO_SHELL */\r
-\r
-\r
-#ifndef PF_NO_FILEIO\r
-\r
-/***************************************************************/\r
-static int32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr )\r
-{\r
-       int32_t numr;\r
-       uint8_t pad[4];\r
-       numr = sdReadFile( pad, 1, sizeof(pad), fid );\r
-       if( numr != sizeof(pad) ) return -1;\r
-       *ValPtr = Read32BigEndian( pad );\r
-       return 0;\r
-}\r
-\r
-/***************************************************************/\r
-PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )\r
-{\r
-       pfDictionary_t *dic = NULL;\r
-       FileStream *fid;\r
-       DictionaryInfoChunk *sd;\r
-       uint32_t ChunkID;\r
-       uint32_t ChunkSize;\r
-       uint32_t FormSize;\r
-       uint32_t BytesLeft;\r
-       uint32_t numr;\r
-       int   isDicBigEndian;\r
-\r
-DBUG(("pfLoadDictionary( %s )\n", FileName ));\r
-\r
-/* Open file. */\r
-       fid = sdOpenFile( FileName, "rb" );\r
-       if( fid == NULL )\r
-       {\r
-               pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE);\r
-               goto xt_error;\r
-       }\r
-\r
-/* Read FORM, Size, ID */\r
-       if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;\r
-       if( ChunkID != ID_FORM )\r
-       {\r
-               pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE);\r
-               goto error;\r
-       }\r
-\r
-       if (Read32FromFile( fid, &FormSize ) < 0) goto read_error;\r
-       BytesLeft = FormSize;\r
-\r
-       if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;\r
-       BytesLeft -= 4;\r
-       if( ChunkID != ID_P4TH )\r
-       {\r
-               pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE);\r
-               goto error;\r
-       }\r
-\r
-/* Scan and parse all chunks in file. */\r
-       while( BytesLeft > 0 )\r
-       {\r
-               if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;\r
-               if (Read32FromFile( fid, &ChunkSize ) < 0) goto read_error;\r
-               BytesLeft -= 8;\r
-\r
-               DBUG(("ChunkID = %4s, Size = %d\n", (char *)&ChunkID, ChunkSize ));\r
-\r
-               switch( ChunkID )\r
-               {\r
-               case ID_P4DI:\r
-                       sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize );\r
-                       if( sd == NULL ) goto nomem_error;\r
-\r
-                       numr = sdReadFile( sd, 1, ChunkSize, fid );\r
-                       if( numr != ChunkSize ) goto read_error;\r
-                       BytesLeft -= ChunkSize;\r
-                       \r
-                       convertDictionaryInfoRead (sd);\r
-\r
-                       isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC;\r
-\r
-                       if( !gVarQuiet )\r
-                       {\r
-                               MSG("pForth loading dictionary from file "); MSG(FileName);\r
-                                       EMIT_CR;\r
-                               MSG_NUM_D("     File format version is ", sd->sd_Version );\r
-                               MSG_NUM_D("     Name space size = ", sd->sd_NameSize );\r
-                               MSG_NUM_D("     Code space size = ", sd->sd_CodeSize );\r
-                               MSG_NUM_D("     Entry Point     = ", sd->sd_EntryPoint );\r
-                               MSG_NUM_D("     Cell Size       = ", sd->sd_CellSize );\r
-                               MSG( (isDicBigEndian ? "     Big Endian Dictionary" :\r
-                                                      "     Little  Endian Dictionary") );\r
-                               if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!");\r
-                                       EMIT_CR;\r
-                       }\r
-\r
-                       if( sd->sd_Version > PF_FILE_VERSION )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE );\r
-                               goto error;\r
-                       }\r
-                       if( sd->sd_Version < PF_EARLIEST_FILE_VERSION )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST );\r
-                               goto error;\r
-                       }\r
-                       if( sd->sd_CellSize != sizeof(cell_t) )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_CELL_SIZE_CONFLICT );\r
-                               goto error;\r
-                       }\r
-                       if( sd->sd_NumPrimitives > NUM_PRIMITIVES )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED );\r
-                               goto error;\r
-                       }\r
-\r
-/* Check to make sure that EndianNess of dictionary matches mode of pForth. */\r
-#if defined(PF_BIG_ENDIAN_DIC)\r
-                       if(isDicBigEndian == 0)\r
-#elif defined(PF_LITTLE_ENDIAN_DIC)\r
-                       if(isDicBigEndian == 1)\r
-#else\r
-                       if( isDicBigEndian == IsHostLittleEndian() )\r
-#endif\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT );\r
-                               goto error;\r
-                       }\r
-\r
-/* Check for compatible float size. */\r
-#ifdef PF_SUPPORT_FP\r
-                       if( sd->sd_FloatSize != sizeof(PF_FLOAT) )\r
-#else\r
-                       if( sd->sd_FloatSize != 0 )\r
-#endif\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT );\r
-                               goto error;\r
-                       }\r
-\r
-                       dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize );\r
-                       if( dic == NULL ) goto nomem_error;\r
-                       gCurrentDictionary = dic;\r
-                       if( sd->sd_NameSize > 0 )\r
-                       {\r
-                               gVarContext = NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */\r
-                               gCurrentDictionary->dic_HeaderPtr = (ucell_t)(uint8_t *)\r
-                                       NAMEREL_TO_ABS(sd->sd_RelHeaderPtr);\r
-                       }\r
-                       else\r
-                       {\r
-                               gVarContext = 0;\r
-                               gCurrentDictionary->dic_HeaderPtr = (ucell_t)NULL;\r
-                       }\r
-                       gCurrentDictionary->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(sd->sd_RelCodePtr);\r
-                       gNumPrimitives = sd->sd_NumPrimitives;  /* Must match compiled dictionary. */\r
-/* Pass EntryPoint back to caller. */\r
-                       if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint;\r
-                       pfFreeMem(sd);\r
-                       break;\r
-\r
-               case ID_P4NM:\r
-#ifdef PF_NO_SHELL\r
-                       pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL );\r
-                       goto error;\r
-#else\r
-                       if( NAME_BASE == 0 )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES );\r
-                               goto error;\r
-                       }\r
-                       if( gCurrentDictionary == NULL )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );\r
-                               goto error;\r
-                       }\r
-                       if( ChunkSize > NAME_SIZE )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);\r
-                               goto error;\r
-                       }\r
-                       numr = sdReadFile( (char *) NAME_BASE, 1, ChunkSize, fid );\r
-                       if( numr != ChunkSize ) goto read_error;\r
-                       BytesLeft -= ChunkSize;\r
-#endif /* PF_NO_SHELL */\r
-                       break;\r
-\r
-               case ID_P4CD:\r
-                       if( gCurrentDictionary == NULL )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );\r
-                               goto error;\r
-                       }\r
-                       if( ChunkSize > CODE_SIZE )\r
-                       {\r
-                               pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);\r
-                               goto error;\r
-                       }\r
-                       numr = sdReadFile( (uint8_t *) CODE_BASE, 1, ChunkSize, fid );\r
-                       if( numr != ChunkSize ) goto read_error;\r
-                       BytesLeft -= ChunkSize;\r
-                       break;\r
-\r
-               default:\r
-                       pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );\r
-                       sdSeekFile( fid, ChunkSize, PF_SEEK_CUR );\r
-                       break;\r
-               }\r
-       }\r
-\r
-       sdCloseFile( fid );\r
-\r
-       if( NAME_BASE != 0)\r
-       {\r
-               cell_t Result;\r
-/* Find special words in dictionary for global XTs. */\r
-               if( (Result = FindSpecialXTs()) < 0 )\r
-               {\r
-                       pfReportError("pfLoadDictionary: FindSpecialXTs", Result);\r
-                       goto error;\r
-               }\r
-       }\r
-\r
-DBUG(("pfLoadDictionary: return %p\n", dic));\r
-       return (PForthDictionary) dic;\r
-\r
-nomem_error:\r
-       pfReportError("pfLoadDictionary", PF_ERR_NO_MEM);\r
-       sdCloseFile( fid );\r
-       return NULL;\r
-\r
-read_error:\r
-       pfReportError("pfLoadDictionary", PF_ERR_READ_FILE);\r
-error:\r
-       sdCloseFile( fid );\r
-xt_error:\r
-       return NULL;\r
-}\r
-\r
-#else\r
-\r
-PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )\r
-{\r
-       (void) FileName;\r
-       (void) EntryPointPtr;\r
-       return NULL;\r
-}\r
-#endif /* !PF_NO_FILEIO */\r
-\r
-\r
-\r
-/***************************************************************/\r
-PForthDictionary pfLoadStaticDictionary( void )\r
-{\r
-#ifdef PF_STATIC_DIC\r
-       cell_t Result;\r
-       pfDictionary_t *dic;\r
-       cell_t NewNameSize, NewCodeSize;\r
-       \r
-       if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )\r
-       {\r
-               MSG( (IF_LITTLE_ENDIAN ?\r
-                            "Little Endian Dictionary on " :\r
-                                "Big Endian Dictionary on ") );\r
-               MSG( (IsHostLittleEndian() ?\r
-                            "Little Endian CPU" :\r
-                                "Big Endian CPU") );\r
-               EMIT_CR;\r
-       }\r
-       \r
-/* Check to make sure that EndianNess of dictionary matches mode of pForth. */\r
-#if defined(PF_BIG_ENDIAN_DIC)\r
-       if(IF_LITTLE_ENDIAN == 1)\r
-#elif defined(PF_LITTLE_ENDIAN_DIC)\r
-       if(IF_LITTLE_ENDIAN == 0)\r
-#else /* Code is native endian! */\r
-       if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )\r
-#endif\r
-       {\r
-               pfReportError("pfLoadStaticDictionary", PF_ERR_ENDIAN_CONFLICT );\r
-               goto error;\r
-       }\r
-\r
-\r
-#ifndef PF_EXTRA_HEADERS\r
-       #define PF_EXTRA_HEADERS  (20000)\r
-#endif\r
-#ifndef PF_EXTRA_CODE\r
-       #define PF_EXTRA_CODE  (40000)\r
-#endif\r
-\r
-/* Copy static const data to allocated dictionaries. */\r
-       NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS;\r
-       NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE;\r
-\r
-       DBUG_NUM_D( "static dic name size = ", NewNameSize );\r
-       DBUG_NUM_D( "static dic code size = ", NewCodeSize );\r
-       \r
-       gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize );\r
-       if( !dic ) goto nomem_error;\r
-\r
-       pfCopyMemory( (uint8_t *) dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) );\r
-       pfCopyMemory( (uint8_t *) dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) );\r
-       DBUG(("Static data copied to newly allocated dictionaries.\n"));\r
-\r
-       dic->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(CODEPTR);\r
-       gNumPrimitives = NUM_PRIMITIVES;\r
-\r
-       if( NAME_BASE != 0)\r
-       {\r
-/* Setup name space. */\r
-               dic->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(HEADERPTR);\r
-               gVarContext = NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */\r
-\r
-/* Find special words in dictionary for global XTs. */\r
-               if( (Result = FindSpecialXTs()) < 0 )\r
-               {\r
-                       pfReportError("pfLoadStaticDictionary: FindSpecialXTs", Result);\r
-                       goto error;\r
-               }\r
-       }\r
-\r
-       return (PForthDictionary) dic;\r
-\r
-error:\r
-       return NULL;\r
-\r
-nomem_error:\r
-       pfReportError("pfLoadStaticDictionary", PF_ERR_NO_MEM);\r
-#endif /* PF_STATIC_DIC */\r
-\r
-       return NULL;\r
-}\r
-\r
+/* @(#) pf_save.c 98/01/26 1.3 */
+/***************************************************************
+** Save and Load Dictionary
+** for PForth based on 'C'
+**
+** Compile file based version or static data based version
+** depending on PF_NO_FILEIO switch.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 940225 PLB Fixed CodePtr save, was using NAMEREL instead of CODEREL
+**            This would only work if the relative location
+**            of names and code was the same when saved and reloaded.
+** 940228 PLB Added PF_NO_FILEIO version
+** 961204 PLB Added PF_STATIC_DIC
+** 000623 PLB Cast chars as ucell_t before shifting for 16 bit systems.
+***************************************************************/
+
+#include <assert.h>
+
+#include "pf_all.h"
+
+/* If no File I/O, then force static dictionary. */
+#ifdef PF_NO_FILEIO
+    #ifndef PF_STATIC_DIC
+        #define PF_STATIC_DIC
+    #endif
+#endif
+
+#ifdef PF_STATIC_DIC
+    #include "pfdicdat.h"
+#endif
+
+/*
+Dictionary File Format based on IFF standard.
+The chunk IDs, sizes, and data values are all Big Endian in conformance with the IFF standard.
+The dictionaries may be big or little endian.
+    'FORM'
+    size
+    'P4TH'  -  Form Identifier
+
+Chunks
+    'P4DI'
+    size
+    struct DictionaryInfoChunk
+
+    'P4NM'
+    size
+    Name and Header portion of dictionary. (Big or Little Endian) (Optional)
+
+    'P4CD'
+    size
+    Code portion of dictionary. (Big or Little Endian)
+*/
+
+
+/***************************************************************/
+/* Endian-ness tools. */
+ucell_t ReadCellBigEndian( const uint8_t *addr )
+{
+    ucell_t temp = (ucell_t)addr[0];
+    temp = (temp << 8) | ((ucell_t)addr[1]);
+    temp = (temp << 8) | ((ucell_t)addr[2]);
+    temp = (temp << 8) | ((ucell_t)addr[3]);
+    if( sizeof(ucell_t) == 8 )
+    {
+        temp = (temp << 8) | ((ucell_t)addr[4]);
+        temp = (temp << 8) | ((ucell_t)addr[5]);
+        temp = (temp << 8) | ((ucell_t)addr[6]);
+        temp = (temp << 8) | ((ucell_t)addr[7]);
+    }
+
+    return temp;
+}
+/***************************************************************/
+/* Endian-ness tools. */
+uint32_t Read32BigEndian( const uint8_t *addr )
+{
+    uint32_t temp = (uint32_t)addr[0];
+    temp = (temp << 8) | ((uint32_t)addr[1]);
+    temp = (temp << 8) | ((uint32_t)addr[2]);
+    temp = (temp << 8) | ((uint32_t)addr[3]);
+    return temp;
+}
+
+/***************************************************************/
+uint16_t Read16BigEndian( const uint8_t *addr )
+{
+    return (uint16_t) ((addr[0]<<8) | addr[1]);
+}
+
+/***************************************************************/
+ucell_t ReadCellLittleEndian( const uint8_t *addr )
+{
+    ucell_t temp = 0;
+    if( sizeof(ucell_t) == 8 )
+    {
+        temp = (temp << 8) | ((uint32_t)addr[7]);
+        temp = (temp << 8) | ((uint32_t)addr[6]);
+        temp = (temp << 8) | ((uint32_t)addr[5]);
+        temp = (temp << 8) | ((uint32_t)addr[4]);
+    }
+    temp = (temp << 8) | ((uint32_t)addr[3]);
+    temp = (temp << 8) | ((uint32_t)addr[2]);
+    temp = (temp << 8) | ((uint32_t)addr[1]);
+    temp = (temp << 8) | ((uint32_t)addr[0]);
+    return temp;
+}
+
+/***************************************************************/
+uint32_t Read32LittleEndian( const uint8_t *addr )
+{
+    uint32_t temp = (uint32_t)addr[3];
+    temp = (temp << 8) | ((uint32_t)addr[2]);
+    temp = (temp << 8) | ((uint32_t)addr[1]);
+    temp = (temp << 8) | ((uint32_t)addr[0]);
+    return temp;
+}
+
+/***************************************************************/
+uint16_t Read16LittleEndian( const uint8_t *addr )
+{
+    const unsigned char *bp = (const unsigned char *) addr;
+    return (uint16_t) ((bp[1]<<8) | bp[0]);
+}
+
+#ifdef PF_SUPPORT_FP
+
+/***************************************************************/
+static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst );
+
+static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst )
+{
+    int i;
+    unsigned char *d = (unsigned char *) dst;
+    const unsigned char *s = (const unsigned char *) src;
+
+    for( i=0; i<sizeof(PF_FLOAT); i++ )
+    {
+        d[i] = s[sizeof(PF_FLOAT) - 1 - i];
+    }
+}
+
+/***************************************************************/
+void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data )
+{
+    if( IsHostLittleEndian() )
+    {
+        ReverseCopyFloat( &data, addr );
+    }
+    else
+    {
+        *addr = data;
+    }
+}
+
+/***************************************************************/
+PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr )
+{
+    PF_FLOAT data;
+    if( IsHostLittleEndian() )
+    {
+        ReverseCopyFloat( addr, &data );
+        return data;
+    }
+    else
+    {
+        return *addr;
+    }
+}
+
+/***************************************************************/
+void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data )
+{
+    if( IsHostLittleEndian() )
+    {
+        *addr = data;
+    }
+    else
+    {
+        ReverseCopyFloat( &data, addr );
+    }
+}
+
+/***************************************************************/
+PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr )
+{
+    PF_FLOAT data;
+    if( IsHostLittleEndian() )
+    {
+        return *addr;
+    }
+    else
+    {
+        ReverseCopyFloat( addr, &data );
+        return data;
+    }
+}
+
+#endif /* PF_SUPPORT_FP */
+
+/***************************************************************/
+void WriteCellBigEndian( uint8_t *addr, ucell_t data )
+{
+    /* Write should be in order of increasing address
+     * to optimize for burst writes to DRAM. */
+    if( sizeof(ucell_t) == 8 )
+    {
+        *addr++ = (uint8_t) (data>>56);
+        *addr++ = (uint8_t) (data>>48);
+        *addr++ = (uint8_t) (data>>40);
+        *addr++ = (uint8_t) (data>>32);
+    }
+    *addr++ = (uint8_t) (data>>24);
+    *addr++ = (uint8_t) (data>>16);
+    *addr++ = (uint8_t) (data>>8);
+    *addr = (uint8_t) (data);
+}
+
+/***************************************************************/
+void Write32BigEndian( uint8_t *addr, uint32_t data )
+{
+    *addr++ = (uint8_t) (data>>24);
+    *addr++ = (uint8_t) (data>>16);
+    *addr++ = (uint8_t) (data>>8);
+    *addr = (uint8_t) (data);
+}
+
+/***************************************************************/
+void Write16BigEndian( uint8_t *addr, uint16_t data )
+{
+    *addr++ = (uint8_t) (data>>8);
+    *addr = (uint8_t) (data);
+}
+
+/***************************************************************/
+void WriteCellLittleEndian( uint8_t *addr, ucell_t data )
+{
+    /* Write should be in order of increasing address
+     * to optimize for burst writes to DRAM. */
+    if( sizeof(ucell_t) == 8 )
+    {
+        *addr++ = (uint8_t) data;  /* LSB at near end */
+        data = data >> 8;
+        *addr++ = (uint8_t) data;
+        data = data >> 8;
+        *addr++ = (uint8_t) data;
+        data = data >> 8;
+        *addr++ = (uint8_t) data;
+        data = data >> 8;
+    }
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr = (uint8_t) data;
+}
+/***************************************************************/
+void Write32LittleEndian( uint8_t *addr, uint32_t data )
+{
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr = (uint8_t) data;
+}
+
+/***************************************************************/
+void Write16LittleEndian( uint8_t *addr, uint16_t data )
+{
+    *addr++ = (uint8_t) data;
+    data = data >> 8;
+    *addr = (uint8_t) data;
+}
+
+/***************************************************************/
+/* Return 1 if host CPU is Little Endian */
+int IsHostLittleEndian( void )
+{
+    static int gEndianCheck = 1;
+    unsigned char *bp = (unsigned char *) &gEndianCheck;
+    return (int) (*bp); /* Return byte pointed to by address. If LSB then == 1 */
+}
+
+#if defined(PF_NO_FILEIO) || defined(PF_NO_SHELL)
+
+cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)
+{
+    TOUCH(FileName);
+    TOUCH(EntryPoint);
+    TOUCH(NameSize);
+    TOUCH(CodeSize);
+
+    pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED);
+    return -1;
+}
+
+#else /* PF_NO_FILEIO or PF_NO_SHELL */
+
+/***************************************************************/
+static int Write32ToFile( FileStream *fid, uint32_t Val )
+{
+    int numw;
+    uint8_t pad[4];
+
+    Write32BigEndian(pad,Val);
+    numw = sdWriteFile( pad, 1, sizeof(pad), fid );
+    if( numw != sizeof(pad) ) return -1;
+    return 0;
+}
+
+/***************************************************************/
+static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t NumBytes )
+{
+    cell_t numw;
+    cell_t EvenNumW;
+
+    EvenNumW = EVENUP(NumBytes);
+
+    if( Write32ToFile( fid, ID ) < 0 ) goto error;
+    if( Write32ToFile( fid, EvenNumW ) < 0 ) goto error;
+
+    numw = sdWriteFile( Data, 1, EvenNumW, fid );
+    if( numw != EvenNumW ) goto error;
+    return 0;
+error:
+    pfReportError("WriteChunkToFile", PF_ERR_WRITE_FILE);
+    return -1;
+}
+
+/* Convert dictionary info chunk between native and on-disk (big-endian). */
+static void
+convertDictionaryInfoWrite (DictionaryInfoChunk *sd)
+{
+/* Convert all fields in DictionaryInfoChunk from Native to BigEndian.
+ * This assumes they are all 32-bit integers.
+ */
+    int   i;
+    uint32_t *p = (uint32_t *) sd;
+    for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)
+    {
+        Write32BigEndian( (uint8_t *)&p[i], p[i] );
+    }
+}
+
+static void
+convertDictionaryInfoRead (DictionaryInfoChunk *sd)
+{
+/* Convert all fields in structure from BigEndian to Native. */
+    int   i;
+    uint32_t *p = (uint32_t *) sd;
+    for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)
+    {
+        p[i] = Read32BigEndian( (uint8_t *)&p[i] );
+    }
+}
+
+/****************************************************************
+** Save Dictionary in File.
+** If EntryPoint is NULL, save as development environment.
+** If EntryPoint is non-NULL, save as turnKey environment with no names.
+*/
+cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)
+{
+    FileStream *fid;
+    DictionaryInfoChunk SD;
+    uint32_t FormSize;
+    uint32_t NameChunkSize = 0;
+    uint32_t CodeChunkSize;
+    uint32_t relativeCodePtr;
+
+    fid = sdOpenFile( FileName, "wb" );
+    if( fid == NULL )
+    {
+        pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE);
+        return -1;
+    }
+
+/* Save in uninitialized form. */
+    pfExecIfDefined("AUTO.TERM");
+
+/* Write FORM Header ---------------------------- */
+    if( Write32ToFile( fid, ID_FORM ) < 0 ) goto error;
+    if( Write32ToFile( fid, 0 ) < 0 ) goto error;
+    if( Write32ToFile( fid, ID_P4TH ) < 0 ) goto error;
+
+/* Write P4DI Dictionary Info  ------------------ */
+    SD.sd_Version = PF_FILE_VERSION;
+
+    relativeCodePtr = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */
+    SD.sd_RelCodePtr = relativeCodePtr;
+    SD.sd_UserStackSize = sizeof(cell_t) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit);
+    SD.sd_ReturnStackSize = sizeof(cell_t) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit);
+    SD.sd_NumPrimitives = gNumPrimitives;  /* Must match compiled dictionary. */
+
+#ifdef PF_SUPPORT_FP
+    SD.sd_FloatSize = sizeof(PF_FLOAT);  /* Must match compiled dictionary. */
+#else
+    SD.sd_FloatSize = 0;
+#endif
+
+    SD.sd_CellSize = sizeof(cell_t);
+
+/* Set bit that specifies whether dictionary is BIG or LITTLE Endian. */
+    {
+#if defined(PF_BIG_ENDIAN_DIC)
+        int eflag = SD_F_BIG_ENDIAN_DIC;
+#elif defined(PF_LITTLE_ENDIAN_DIC)
+        int eflag = 0;
+#else
+        int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC;
+#endif
+        SD.sd_Flags = eflag;
+    }
+
+    if( EntryPoint )
+    {
+        SD.sd_EntryPoint = EntryPoint;  /* Turnkey! */
+    }
+    else
+    {
+        SD.sd_EntryPoint = 0;
+    }
+
+/* Do we save names? */
+    if( NameSize == 0 )
+    {
+        SD.sd_RelContext = 0;
+        SD.sd_RelHeaderPtr = 0;
+        SD.sd_NameSize = 0;
+    }
+    else
+    {
+        uint32_t relativeHeaderPtr;
+/* Development mode. */
+        SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext);
+        relativeHeaderPtr = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr);
+        SD.sd_RelHeaderPtr = relativeHeaderPtr;
+
+/* How much real name space is there? */
+        NameChunkSize = QUADUP(relativeHeaderPtr);  /* Align */
+
+/* NameSize must be 0 or greater than NameChunkSize + 1K */
+        NameSize = QUADUP(NameSize);  /* Align */
+        if( NameSize > 0 )
+        {
+            NameSize = MAX( NameSize, (NameChunkSize + 1024) );
+        }
+        SD.sd_NameSize = NameSize;
+    }
+
+/* How much real code is there? */
+    CodeChunkSize = QUADUP(relativeCodePtr);
+    CodeSize = QUADUP(CodeSize);  /* Align */
+    CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) );
+    SD.sd_CodeSize = CodeSize;
+
+
+    convertDictionaryInfoWrite (&SD);
+
+    if( WriteChunkToFile( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error;
+
+/* Write Name Fields if NameSize non-zero ------- */
+    if( NameSize > 0 )
+    {
+        if( WriteChunkToFile( fid, ID_P4NM, (char *) NAME_BASE,
+            NameChunkSize ) < 0 ) goto error;
+    }
+
+/* Write Code Fields ---------------------------- */
+    if( WriteChunkToFile( fid, ID_P4CD, (char *) CODE_BASE,
+        CodeChunkSize ) < 0 ) goto error;
+
+    FormSize = sdTellFile( fid ) - 8;
+    sdSeekFile( fid, 4, PF_SEEK_SET );
+    if( Write32ToFile( fid, FormSize ) < 0 ) goto error;
+
+    sdCloseFile( fid );
+
+/* Restore initialization. */
+    pfExecIfDefined("AUTO.INIT");
+    return 0;
+
+error:
+    sdSeekFile( fid, 0, PF_SEEK_SET );
+    Write32ToFile( fid, ID_BADF ); /* Mark file as bad. */
+    sdCloseFile( fid );
+
+/* Restore initialization. */
+    pfExecIfDefined("AUTO.INIT");
+
+    return -1;
+}
+
+#endif /* !PF_NO_FILEIO and !PF_NO_SHELL */
+
+
+#ifndef PF_NO_FILEIO
+
+/***************************************************************/
+static int32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr )
+{
+    int32_t numr;
+    uint8_t pad[4];
+    numr = sdReadFile( pad, 1, sizeof(pad), fid );
+    if( numr != sizeof(pad) ) return -1;
+    *ValPtr = Read32BigEndian( pad );
+    return 0;
+}
+
+/***************************************************************/
+PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )
+{
+    pfDictionary_t *dic = NULL;
+    FileStream *fid;
+    DictionaryInfoChunk *sd;
+    uint32_t ChunkID;
+    uint32_t ChunkSize;
+    uint32_t FormSize;
+    uint32_t BytesLeft;
+    uint32_t numr;
+    int   isDicBigEndian;
+
+DBUG(("pfLoadDictionary( %s )\n", FileName ));
+
+/* Open file. */
+    fid = sdOpenFile( FileName, "rb" );
+    if( fid == NULL )
+    {
+        pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE);
+        goto xt_error;
+    }
+
+/* Read FORM, Size, ID */
+    if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
+    if( ChunkID != ID_FORM )
+    {
+        pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE);
+        goto error;
+    }
+
+    if (Read32FromFile( fid, &FormSize ) < 0) goto read_error;
+    BytesLeft = FormSize;
+
+    if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
+    BytesLeft -= 4;
+    if( ChunkID != ID_P4TH )
+    {
+        pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE);
+        goto error;
+    }
+
+/* Scan and parse all chunks in file. */
+    while( BytesLeft > 0 )
+    {
+        if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
+        if (Read32FromFile( fid, &ChunkSize ) < 0) goto read_error;
+        BytesLeft -= 8;
+
+        DBUG(("ChunkID = %4s, Size = %d\n", (char *)&ChunkID, ChunkSize ));
+
+        switch( ChunkID )
+        {
+        case ID_P4DI:
+            sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize );
+            if( sd == NULL ) goto nomem_error;
+
+            numr = sdReadFile( sd, 1, ChunkSize, fid );
+            if( numr != ChunkSize ) goto read_error;
+            BytesLeft -= ChunkSize;
+
+            convertDictionaryInfoRead (sd);
+
+            isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC;
+
+            if( !gVarQuiet )
+            {
+                MSG("pForth loading dictionary from file "); MSG(FileName);
+                    EMIT_CR;
+                MSG_NUM_D("     File format version is ", sd->sd_Version );
+                MSG_NUM_D("     Name space size = ", sd->sd_NameSize );
+                MSG_NUM_D("     Code space size = ", sd->sd_CodeSize );
+                MSG_NUM_D("     Entry Point     = ", sd->sd_EntryPoint );
+                MSG_NUM_D("     Cell Size       = ", sd->sd_CellSize );
+                MSG( (isDicBigEndian ? "     Big Endian Dictionary" :
+                                       "     Little  Endian Dictionary") );
+                if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!");
+                    EMIT_CR;
+            }
+
+            if( sd->sd_Version > PF_FILE_VERSION )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE );
+                goto error;
+            }
+            if( sd->sd_Version < PF_EARLIEST_FILE_VERSION )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST );
+                goto error;
+            }
+            if( sd->sd_CellSize != sizeof(cell_t) )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_CELL_SIZE_CONFLICT );
+                goto error;
+            }
+            if( sd->sd_NumPrimitives > NUM_PRIMITIVES )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED );
+                goto error;
+            }
+
+/* Check to make sure that EndianNess of dictionary matches mode of pForth. */
+#if defined(PF_BIG_ENDIAN_DIC)
+            if(isDicBigEndian == 0)
+#elif defined(PF_LITTLE_ENDIAN_DIC)
+            if(isDicBigEndian == 1)
+#else
+            if( isDicBigEndian == IsHostLittleEndian() )
+#endif
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT );
+                goto error;
+            }
+
+/* Check for compatible float size. */
+#ifdef PF_SUPPORT_FP
+            if( sd->sd_FloatSize != sizeof(PF_FLOAT) )
+#else
+            if( sd->sd_FloatSize != 0 )
+#endif
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT );
+                goto error;
+            }
+
+            dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize );
+            if( dic == NULL ) goto nomem_error;
+            gCurrentDictionary = dic;
+            if( sd->sd_NameSize > 0 )
+            {
+                gVarContext = NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */
+                gCurrentDictionary->dic_HeaderPtr = (ucell_t)(uint8_t *)
+                    NAMEREL_TO_ABS(sd->sd_RelHeaderPtr);
+            }
+            else
+            {
+                gVarContext = 0;
+                gCurrentDictionary->dic_HeaderPtr = (ucell_t)NULL;
+            }
+            gCurrentDictionary->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(sd->sd_RelCodePtr);
+            gNumPrimitives = sd->sd_NumPrimitives;  /* Must match compiled dictionary. */
+/* Pass EntryPoint back to caller. */
+            if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint;
+            pfFreeMem(sd);
+            break;
+
+        case ID_P4NM:
+#ifdef PF_NO_SHELL
+            pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL );
+            goto error;
+#else
+            if( NAME_BASE == 0 )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES );
+                goto error;
+            }
+            if( gCurrentDictionary == NULL )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
+                goto error;
+            }
+            if( ChunkSize > NAME_SIZE )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);
+                goto error;
+            }
+            numr = sdReadFile( (char *) NAME_BASE, 1, ChunkSize, fid );
+            if( numr != ChunkSize ) goto read_error;
+            BytesLeft -= ChunkSize;
+#endif /* PF_NO_SHELL */
+            break;
+
+        case ID_P4CD:
+            if( gCurrentDictionary == NULL )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
+                goto error;
+            }
+            if( ChunkSize > CODE_SIZE )
+            {
+                pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);
+                goto error;
+            }
+            numr = sdReadFile( (uint8_t *) CODE_BASE, 1, ChunkSize, fid );
+            if( numr != ChunkSize ) goto read_error;
+            BytesLeft -= ChunkSize;
+            break;
+
+        default:
+            pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
+            sdSeekFile( fid, ChunkSize, PF_SEEK_CUR );
+            break;
+        }
+    }
+
+    sdCloseFile( fid );
+
+    if( NAME_BASE != 0)
+    {
+        cell_t Result;
+/* Find special words in dictionary for global XTs. */
+        if( (Result = FindSpecialXTs()) < 0 )
+        {
+            pfReportError("pfLoadDictionary: FindSpecialXTs", Result);
+            goto error;
+        }
+    }
+
+DBUG(("pfLoadDictionary: return %p\n", dic));
+    return (PForthDictionary) dic;
+
+nomem_error:
+    pfReportError("pfLoadDictionary", PF_ERR_NO_MEM);
+    sdCloseFile( fid );
+    return NULL;
+
+read_error:
+    pfReportError("pfLoadDictionary", PF_ERR_READ_FILE);
+error:
+    sdCloseFile( fid );
+xt_error:
+    return NULL;
+}
+
+#else
+
+PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )
+{
+    (void) FileName;
+    (void) EntryPointPtr;
+    return NULL;
+}
+#endif /* !PF_NO_FILEIO */
+
+
+
+/***************************************************************/
+PForthDictionary pfLoadStaticDictionary( void )
+{
+#ifdef PF_STATIC_DIC
+    cell_t Result;
+    pfDictionary_t *dic;
+    cell_t NewNameSize, NewCodeSize;
+
+    if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )
+    {
+        MSG( (IF_LITTLE_ENDIAN ?
+                 "Little Endian Dictionary on " :
+                 "Big Endian Dictionary on ") );
+        MSG( (IsHostLittleEndian() ?
+                 "Little Endian CPU" :
+                 "Big Endian CPU") );
+        EMIT_CR;
+    }
+
+/* Check to make sure that EndianNess of dictionary matches mode of pForth. */
+#if defined(PF_BIG_ENDIAN_DIC)
+    if(IF_LITTLE_ENDIAN == 1)
+#elif defined(PF_LITTLE_ENDIAN_DIC)
+    if(IF_LITTLE_ENDIAN == 0)
+#else /* Code is native endian! */
+    if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )
+#endif
+    {
+        pfReportError("pfLoadStaticDictionary", PF_ERR_ENDIAN_CONFLICT );
+        goto error;
+    }
+
+
+#ifndef PF_EXTRA_HEADERS
+    #define PF_EXTRA_HEADERS  (20000)
+#endif
+#ifndef PF_EXTRA_CODE
+    #define PF_EXTRA_CODE  (40000)
+#endif
+
+/* Copy static const data to allocated dictionaries. */
+    NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS;
+    NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE;
+
+    DBUG_NUM_D( "static dic name size = ", NewNameSize );
+    DBUG_NUM_D( "static dic code size = ", NewCodeSize );
+
+    gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize );
+    if( !dic ) goto nomem_error;
+
+    pfCopyMemory( (uint8_t *) dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) );
+    pfCopyMemory( (uint8_t *) dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) );
+    DBUG(("Static data copied to newly allocated dictionaries.\n"));
+
+    dic->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(CODEPTR);
+    gNumPrimitives = NUM_PRIMITIVES;
+
+    if( NAME_BASE != 0)
+    {
+/* Setup name space. */
+        dic->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(HEADERPTR);
+        gVarContext = NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */
+
+/* Find special words in dictionary for global XTs. */
+        if( (Result = FindSpecialXTs()) < 0 )
+        {
+            pfReportError("pfLoadStaticDictionary: FindSpecialXTs", Result);
+            goto error;
+        }
+    }
+
+    return (PForthDictionary) dic;
+
+error:
+    return NULL;
+
+nomem_error:
+    pfReportError("pfLoadStaticDictionary", PF_ERR_NO_MEM);
+#endif /* PF_STATIC_DIC */
+
+    return NULL;
+}
+

diff --git a/csrc/pf_save.h b/csrc/pf_save.h
index 3bf8c2f..00f2802 100644 (file)
--- a/csrc/pf_save.h
+++ b/csrc/pf_save.h
@@ -1,100 +1,100 @@
-/* @(#) pf_save.h 96/12/18 1.8 */\r
-#ifndef _pforth_save_h\r
-#define _pforth_save_h\r
-\r
-/***************************************************************\r
-** Include file for PForth SaveForth\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-**     941031  rdg             fix redefinition of MAKE_ID and EVENUP to be conditional\r
-**\r
-***************************************************************/\r
-\r
-\r
-typedef struct DictionaryInfoChunk\r
-{\r
-/* All fields are stored in BIG ENDIAN format for consistency in data files.\r
- * All fields must be the same size for easy endian conversion.\r
- * All fields must be 32 bit for file compatibility with older versions.\r
- */\r
-       int32_t  sd_Version;\r
-       int32_t  sd_RelContext;      /* relative ptr to Dictionary Context */\r
-       int32_t  sd_RelHeaderPtr;    /* relative ptr to Dictionary Header Ptr */\r
-       int32_t  sd_RelCodePtr;      /* relative ptr to Dictionary Header Ptr */\r
-       int32_t  sd_EntryPoint;  /* relative ptr to entry point or NULL */\r
-       int32_t  sd_UserStackSize;   /* in bytes */\r
-       int32_t  sd_ReturnStackSize; /* in bytes */\r
-       int32_t  sd_NameSize;        /* in bytes */\r
-       int32_t  sd_CodeSize;        /* in bytes */\r
-       int32_t  sd_NumPrimitives;   /* To distinguish between primitive and secondary. */\r
-       uint32_t sd_Flags;\r
-       int32_t  sd_FloatSize;       /* In bytes. Must match code. 0 means no floats. */\r
-       int32_t  sd_CellSize;        /* In bytes. Must match code. */\r
-} DictionaryInfoChunk;\r
-\r
-/* Bits in sd_Flags */\r
-#define SD_F_BIG_ENDIAN_DIC    (1<<0)\r
-\r
-#ifndef MAKE_ID\r
-#define MAKE_ID(a,b,c,d) ((((uint32_t)a)<<24)|(((uint32_t)b)<<16)|(((uint32_t)c)<<8)|((uint32_t)d))\r
-#endif\r
-\r
-#define ID_FORM MAKE_ID('F','O','R','M')\r
-#define ID_P4TH MAKE_ID('P','4','T','H')\r
-#define ID_P4DI MAKE_ID('P','4','D','I')\r
-#define ID_P4NM MAKE_ID('P','4','N','M')\r
-#define ID_P4CD MAKE_ID('P','4','C','D')\r
-#define ID_BADF MAKE_ID('B','A','D','F')\r
-\r
-#ifndef EVENUP\r
-#define EVENUP(n) ((n+1)&(~1))\r
-#endif\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize );\r
-\r
-/* Endian-ness tools. */\r
-int    IsHostLittleEndian( void );\r
-       \r
-ucell_t ReadCellBigEndian( const uint8_t *addr );\r
-uint32_t Read32BigEndian( const uint8_t *addr );\r
-uint16_t Read16BigEndian( const uint8_t *addr );\r
-       \r
-ucell_t ReadCellLittleEndian( const uint8_t *addr );\r
-uint32_t Read32LittleEndian( const uint8_t *addr );\r
-uint16_t Read16LittleEndian( const uint8_t *addr );\r
-       \r
-void WriteCellBigEndian( uint8_t *addr, ucell_t data );\r
-void Write32BigEndian( uint8_t *addr, uint32_t data );\r
-void Write16BigEndian( uint8_t *addr, uint16_t data );\r
-       \r
-void WriteCellLittleEndian( uint8_t *addr, ucell_t data );\r
-void Write32LittleEndian( uint8_t *addr, uint32_t data );\r
-void Write16LittleEndian( uint8_t *addr, uint16_t data );\r
-\r
-#ifdef PF_SUPPORT_FP\r
-void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data );\r
-PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr );\r
-void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data );\r
-PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr );\r
-#endif\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pforth_save_h */\r
+/* @(#) pf_save.h 96/12/18 1.8 */
+#ifndef _pforth_save_h
+#define _pforth_save_h
+
+/***************************************************************
+** Include file for PForth SaveForth
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+**  941031  rdg     fix redefinition of MAKE_ID and EVENUP to be conditional
+**
+***************************************************************/
+
+
+typedef struct DictionaryInfoChunk
+{
+/* All fields are stored in BIG ENDIAN format for consistency in data files.
+ * All fields must be the same size for easy endian conversion.
+ * All fields must be 32 bit for file compatibility with older versions.
+ */
+    int32_t  sd_Version;
+    int32_t  sd_RelContext;      /* relative ptr to Dictionary Context */
+    int32_t  sd_RelHeaderPtr;    /* relative ptr to Dictionary Header Ptr */
+    int32_t  sd_RelCodePtr;      /* relative ptr to Dictionary Header Ptr */
+    int32_t  sd_EntryPoint;  /* relative ptr to entry point or NULL */
+    int32_t  sd_UserStackSize;   /* in bytes */
+    int32_t  sd_ReturnStackSize; /* in bytes */
+    int32_t  sd_NameSize;        /* in bytes */
+    int32_t  sd_CodeSize;        /* in bytes */
+    int32_t  sd_NumPrimitives;   /* To distinguish between primitive and secondary. */
+    uint32_t sd_Flags;
+    int32_t  sd_FloatSize;       /* In bytes. Must match code. 0 means no floats. */
+    int32_t  sd_CellSize;        /* In bytes. Must match code. */
+} DictionaryInfoChunk;
+
+/* Bits in sd_Flags */
+#define SD_F_BIG_ENDIAN_DIC    (1<<0)
+
+#ifndef MAKE_ID
+#define MAKE_ID(a,b,c,d) ((((uint32_t)a)<<24)|(((uint32_t)b)<<16)|(((uint32_t)c)<<8)|((uint32_t)d))
+#endif
+
+#define ID_FORM MAKE_ID('F','O','R','M')
+#define ID_P4TH MAKE_ID('P','4','T','H')
+#define ID_P4DI MAKE_ID('P','4','D','I')
+#define ID_P4NM MAKE_ID('P','4','N','M')
+#define ID_P4CD MAKE_ID('P','4','C','D')
+#define ID_BADF MAKE_ID('B','A','D','F')
+
+#ifndef EVENUP
+#define EVENUP(n) ((n+1)&(~1))
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize );
+
+/* Endian-ness tools. */
+int    IsHostLittleEndian( void );
+
+ucell_t ReadCellBigEndian( const uint8_t *addr );
+uint32_t Read32BigEndian( const uint8_t *addr );
+uint16_t Read16BigEndian( const uint8_t *addr );
+
+ucell_t ReadCellLittleEndian( const uint8_t *addr );
+uint32_t Read32LittleEndian( const uint8_t *addr );
+uint16_t Read16LittleEndian( const uint8_t *addr );
+
+void WriteCellBigEndian( uint8_t *addr, ucell_t data );
+void Write32BigEndian( uint8_t *addr, uint32_t data );
+void Write16BigEndian( uint8_t *addr, uint16_t data );
+
+void WriteCellLittleEndian( uint8_t *addr, ucell_t data );
+void Write32LittleEndian( uint8_t *addr, uint32_t data );
+void Write16LittleEndian( uint8_t *addr, uint16_t data );
+
+#ifdef PF_SUPPORT_FP
+void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data );
+PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr );
+void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data );
+PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr );
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pforth_save_h */

diff --git a/csrc/pf_text.c b/csrc/pf_text.c
index 9325851..e48e457 100644 (file)
--- a/csrc/pf_text.c
+++ b/csrc/pf_text.c
@@ -1,407 +1,407 @@
-/* @(#) pf_text.c 98/01/26 1.3 */\r
-/***************************************************************\r
-** Text Strings for Error Messages\r
-** Various Text tools.\r
-**\r
-** For PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers.\r
-** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-#define PF_ENGLISH\r
-\r
-/*\r
-** Define array of error messages.\r
-** These are defined in one place to make it easier to translate them.\r
-*/\r
-#ifdef PF_ENGLISH\r
-/***************************************************************/\r
-void pfReportError( const char *FunctionName, Err ErrCode )\r
-{\r
-       const char *s;\r
-       \r
-       MSG("Error in ");\r
-       MSG(FunctionName);\r
-       MSG(" - ");\r
-       \r
-       switch(ErrCode & 0xFF)\r
-       {\r
-       case PF_ERR_NO_MEM & 0xFF:\r
-               s = "insufficient memory"; break;\r
-       case PF_ERR_TOO_BIG & 0xFF:\r
-               s = "data chunk too large"; break;\r
-       case PF_ERR_NUM_PARAMS & 0xFF:\r
-               s = "incorrect number of parameters"; break;\r
-       case PF_ERR_OPEN_FILE & 0xFF:\r
-               s = "could not open file"; break;\r
-       case PF_ERR_WRONG_FILE & 0xFF:\r
-               s = "wrong type of file format"; break;\r
-       case PF_ERR_BAD_FILE & 0xFF:\r
-               s = "badly formatted file"; break;\r
-       case PF_ERR_READ_FILE & 0xFF:\r
-               s = "file read failed"; break;\r
-       case PF_ERR_WRITE_FILE & 0xFF:\r
-               s = "file write failed"; break;\r
-       case PF_ERR_CORRUPT_DIC & 0xFF:\r
-               s = "corrupted dictionary"; break;\r
-       case PF_ERR_NOT_SUPPORTED & 0xFF:\r
-               s = "not supported in this version"; break;\r
-       case PF_ERR_VERSION_FUTURE & 0xFF:\r
-               s = "version from future"; break;\r
-       case PF_ERR_VERSION_PAST & 0xFF:\r
-               s = "version is obsolete. Rebuild new one."; break;\r
-       case PF_ERR_COLON_STACK & 0xFF:\r
-               s = "stack depth changed between : and ; . Probably unbalanced conditional"; break;\r
-       case PF_ERR_HEADER_ROOM & 0xFF:\r
-               s = "no room left in header space"; break;\r
-       case PF_ERR_CODE_ROOM & 0xFF:\r
-               s = "no room left in code space"; break;\r
-       case PF_ERR_NO_SHELL & 0xFF:\r
-               s = "attempt to use names in forth compiled with PF_NO_SHELL"; break;\r
-       case PF_ERR_NO_NAMES & 0xFF:\r
-               s = "dictionary has no names";  break;\r
-       case PF_ERR_OUT_OF_RANGE & 0xFF:\r
-               s = "parameter out of range";  break;\r
-       case PF_ERR_ENDIAN_CONFLICT & 0xFF:\r
-               s = "endian-ness of dictionary does not match code";  break;\r
-       case PF_ERR_FLOAT_CONFLICT & 0xFF:\r
-               s = "float support mismatch between .dic file and code";  break;\r
-       case PF_ERR_CELL_SIZE_CONFLICT & 0xFF:\r
-               s = "cell size mismatch between .dic file and code";  break;\r
-       default:\r
-               s = "unrecognized error code!"; break;\r
-       }\r
-       MSG(s);\r
-       EMIT_CR;\r
-}\r
-\r
-void pfReportThrow( ThrowCode code )\r
-{\r
-       const char *s = NULL;\r
-       switch(code)\r
-       {\r
-       case THROW_ABORT:\r
-       case THROW_ABORT_QUOTE:\r
-               s = "ABORT"; break;\r
-       case THROW_STACK_OVERFLOW:\r
-               s = "Stack overflow!"; break;\r
-       case THROW_STACK_UNDERFLOW:\r
-               s = "Stack underflow!"; break;\r
-       case THROW_EXECUTING:\r
-               s = "Executing a compile-only word!"; break;\r
-       case THROW_FLOAT_STACK_UNDERFLOW:\r
-               s = "Float Stack underflow!"; break;\r
-       case THROW_UNDEFINED_WORD:\r
-               s = "Undefined word!"; break;\r
-       case THROW_PAIRS:\r
-               s = "Conditional control structure mismatch!"; break;\r
-       case THROW_BYE:\r
-       case THROW_QUIT:\r
-               break;\r
-       case THROW_SEMICOLON:\r
-               s = "Stack depth changed between : and ; . Probably unbalanced conditional!"; break;\r
-       case THROW_DEFERRED:\r
-               s = "Not a DEFERred word!"; break;\r
-       default:\r
-               s = "Unrecognized throw code!"; break;\r
-       }\r
-       \r
-       if( s )\r
-       {\r
-               MSG_NUM_D("THROW code = ", code );\r
-               MSG(s);\r
-               EMIT_CR;\r
-       }\r
-}\r
-#endif\r
-\r
-/**************************************************************\r
-** Copy a Forth String to a 'C' string.\r
-*/\r
-\r
-char *ForthStringToC( char *dst, const char *FString, cell_t dstSize )\r
-{\r
-       cell_t Len;\r
-\r
-       Len = (cell_t) *FString;\r
-       /* Make sure the text + NUL can fit. */\r
-       if( Len >= dstSize )\r
-       {\r
-               Len = dstSize - 1;\r
-       }\r
-       pfCopyMemory( dst, FString+1, Len );\r
-       dst[Len] = '\0';\r
-\r
-       return dst;\r
-}\r
-\r
-/**************************************************************\r
-** Copy a NUL terminated string to a Forth counted string.\r
-*/\r
-char *CStringToForth( char *dst, const char *CString, cell_t dstSize )\r
-{\r
-       cell_t i;\r
-\r
-       /* Make sure the SIZE+text can fit. */\r
-       for( i=1; i<dstSize; i++ )\r
-       {\r
-               if( *CString == 0 )\r
-               {\r
-                       break;\r
-               }\r
-               dst[i] = *CString++;\r
-       }\r
-       *dst = (char ) i-1;\r
-       return dst;\r
-}\r
-\r
-/**************************************************************\r
-** Compare two test strings, case sensitive.\r
-** Return TRUE if they match.\r
-*/\r
-cell_t ffCompareText( const char *s1, const char *s2, cell_t len )\r
-{\r
-       cell_t i, Result;\r
-       \r
-       Result = TRUE;\r
-       for( i=0; i<len; i++ )\r
-       {\r
-DBUGX(("ffCompareText: *s1 = 0x%x, *s2 = 0x%x\n", *s1, *s2 ));\r
-               if( *s1++ != *s2++ )\r
-               {\r
-                       Result = FALSE;\r
-                       break;\r
-               }\r
-       }\r
-DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
-       return Result;\r
-}\r
-\r
-/**************************************************************\r
-** Compare two test strings, case INsensitive.\r
-** Return TRUE if they match.\r
-*/\r
-cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len )\r
-{\r
-       cell_t i, Result;\r
-       char  c1,c2;\r
-       \r
-       Result = TRUE;\r
-       for( i=0; i<len; i++ )\r
-       {\r
-               c1 = pfCharToLower(*s1++);\r
-               c2 = pfCharToLower(*s2++);\r
-DBUGX(("ffCompareText: c1 = 0x%x, c2 = 0x%x\n", c1, c2 ));\r
-               if( c1 != c2 )\r
-               {\r
-                       Result = FALSE;\r
-                       break;\r
-               }\r
-       }\r
-DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
-       return Result;\r
-}\r
-\r
-/**************************************************************\r
-** Compare two strings, case sensitive.\r
-** Return zero if they match, -1 if s1<s2, +1 is s1>s2;\r
-*/\r
-cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 )\r
-{\r
-       cell_t i, result, n, diff;\r
-       \r
-       result = 0;\r
-       n = MIN(len1,len2);\r
-       for( i=0; i<n; i++ )\r
-       {\r
-               if( (diff = (*s2++ - *s1++)) != 0 )\r
-               {\r
-                       result = (diff > 0) ? -1 : 1 ;\r
-                       break;\r
-               }\r
-       }\r
-       if( result == 0 )  /* Match up to MIN(len1,len2) */\r
-       {\r
-               if( len1 < len2 )\r
-               {\r
-                       result = -1;\r
-               }\r
-               else if ( len1 > len2 )\r
-               {\r
-                       result = 1;\r
-               }\r
-       }\r
-       return result;\r
-}\r
-\r
-/***************************************************************\r
-** Convert number to text.\r
-*/\r
-#define CNTT_PAD_SIZE ((sizeof(cell_t)*8)+2)  /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */\r
-static char cnttPad[CNTT_PAD_SIZE];\r
-\r
-char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars )\r
-{\r
-       cell_t IfNegative = 0;\r
-       char *p,c;\r
-       ucell_t NewNum, Rem, uNum;\r
-       cell_t i = 0;\r
-       \r
-       uNum = Num;\r
-       if( IfSigned )\r
-       {\r
-/* Convert to positive and keep sign. */\r
-               if( Num < 0 )\r
-               {\r
-                       IfNegative = TRUE;\r
-                       uNum = -Num;\r
-               }\r
-       }\r
-       \r
-/* Point past end of Pad */\r
-       p = cnttPad + CNTT_PAD_SIZE;\r
-       *(--p) = (char) 0; /* NUL terminate */\r
-       \r
-       while( (i++<MinChars) || (uNum != 0) )\r
-       {\r
-               NewNum = uNum / Base;\r
-               Rem = uNum - (NewNum * Base);\r
-               c = (char) (( Rem < 10 ) ? (Rem + '0') : (Rem - 10 + 'A'));\r
-               *(--p) = c;\r
-               uNum = NewNum;\r
-       }\r
-       \r
-       if( IfSigned )\r
-       {\r
-               if( IfNegative ) *(--p) = '-';\r
-       }\r
-       return p;\r
-}\r
-\r
-/***************************************************************\r
-** Diagnostic routine that prints memory in table format.\r
-*/\r
-void DumpMemory( void *addr, cell_t cnt)\r
-{\r
-       cell_t ln, cn, nlines;\r
-       unsigned char *ptr, *cptr, c;\r
-\r
-       nlines = (cnt + 15) / 16;\r
-\r
-       ptr = (unsigned char *) addr;\r
-\r
-       EMIT_CR;\r
-       \r
-       for (ln=0; ln<nlines; ln++)\r
-       {\r
-               MSG( ConvertNumberToText( (cell_t) ptr, 16, FALSE, 8 ) );\r
-               MSG(": ");\r
-               cptr = ptr;\r
-               for (cn=0; cn<16; cn++)\r
-               {\r
-                       MSG( ConvertNumberToText( (cell_t) *cptr++, 16, FALSE, 2 ) );\r
-                       EMIT(' ');\r
-               }\r
-               EMIT(' ');\r
-               for (cn=0; cn<16; cn++)\r
-               {\r
-                       c = *ptr++;\r
-                       if ((c < ' ') || (c > '}')) c = '.';\r
-                       EMIT(c);\r
-               }\r
-               EMIT_CR;\r
-       }\r
-}\r
-\r
-\r
-/* Print name, mask off any dictionary bits. */\r
-void TypeName( const char *Name )\r
-{\r
-       const char *FirstChar;\r
-       cell_t Len;\r
-       \r
-       FirstChar = Name+1;\r
-       Len = *Name & 0x1F;\r
-       \r
-       ioType( FirstChar, Len );\r
-}\r
-\r
-\r
-\r
-#ifdef PF_UNIT_TEST\r
-/* Unit test for string conversion routines. */\r
-#define ASSERT_PAD_IS( index, value, msg ) \\r
-       if( pad[index] != ((char)(value)) ) \\r
-       { \\r
-               ERR(( "ERROR text test failed: " msg "\n")); \\r
-               numErrors += 1; \\r
-       } \\r
-\r
-cell_t pfUnitTestText( void )\r
-{\r
-       cell_t numErrors = 0;\r
-       char pad[16];\r
-       char fpad[8];\r
-\r
-       /* test CStringToForth */\r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       CStringToForth( pad, "frog", 6 );\r
-       ASSERT_PAD_IS( 0, 4, "CS len 6" );\r
-       ASSERT_PAD_IS( 4, 'g', "CS end 6" );\r
-       ASSERT_PAD_IS( 5, 0xA5, "CS past 6" );\r
-       \r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       CStringToForth( pad, "frog", 5 );\r
-       ASSERT_PAD_IS( 0, 4, "CS len 5" );\r
-       ASSERT_PAD_IS( 4, 'g', "CS end 5" );\r
-       ASSERT_PAD_IS( 5, 0xA5, "CS past 5" );\r
-       \r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       CStringToForth( pad, "frog", 4 );\r
-       ASSERT_PAD_IS( 0, 3, "CS len 4" );\r
-       ASSERT_PAD_IS( 3, 'o', "CS end 4" );\r
-       ASSERT_PAD_IS( 4, 0xA5, "CS past 4" );\r
-       \r
-       /* Make a Forth string for testing ForthStringToC. */\r
-       CStringToForth( fpad, "frog", sizeof(fpad) );\r
-       \r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       ForthStringToC( pad, fpad, 6 );\r
-       ASSERT_PAD_IS( 0, 'f', "FS len 6" );\r
-       ASSERT_PAD_IS( 3, 'g', "FS end 6" );\r
-       ASSERT_PAD_IS( 4, 0, "FS nul 6" );\r
-       ASSERT_PAD_IS( 5, 0xA5, "FS past 6" );\r
-       \r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       ForthStringToC( pad, fpad, 5 );\r
-       ASSERT_PAD_IS( 0, 'f', "FS len 5" );\r
-       ASSERT_PAD_IS( 3, 'g', "FS end 5" );\r
-       ASSERT_PAD_IS( 4, 0, "FS nul 5" );\r
-       ASSERT_PAD_IS( 5, 0xA5, "FS past 5" );\r
-       \r
-       pfSetMemory(pad,0xA5,sizeof(pad));\r
-       ForthStringToC( pad, fpad, 4 );\r
-       ASSERT_PAD_IS( 0, 'f', "FS len 4" );\r
-       ASSERT_PAD_IS( 2, 'o', "FS end 4" );\r
-       ASSERT_PAD_IS( 3, 0, "FS nul 4" );\r
-       ASSERT_PAD_IS( 4, 0xA5, "FS past 4" );\r
-       \r
-       return numErrors;\r
-}\r
-#endif\r
+/* @(#) pf_text.c 98/01/26 1.3 */
+/***************************************************************
+** Text Strings for Error Messages
+** Various Text tools.
+**
+** For PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers.
+** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.
+***************************************************************/
+
+#include "pf_all.h"
+
+#define PF_ENGLISH
+
+/*
+** Define array of error messages.
+** These are defined in one place to make it easier to translate them.
+*/
+#ifdef PF_ENGLISH
+/***************************************************************/
+void pfReportError( const char *FunctionName, Err ErrCode )
+{
+    const char *s;
+
+    MSG("Error in ");
+    MSG(FunctionName);
+    MSG(" - ");
+
+    switch(ErrCode & 0xFF)
+    {
+    case PF_ERR_NO_MEM & 0xFF:
+        s = "insufficient memory"; break;
+    case PF_ERR_TOO_BIG & 0xFF:
+        s = "data chunk too large"; break;
+    case PF_ERR_NUM_PARAMS & 0xFF:
+        s = "incorrect number of parameters"; break;
+    case PF_ERR_OPEN_FILE & 0xFF:
+        s = "could not open file"; break;
+    case PF_ERR_WRONG_FILE & 0xFF:
+        s = "wrong type of file format"; break;
+    case PF_ERR_BAD_FILE & 0xFF:
+        s = "badly formatted file"; break;
+    case PF_ERR_READ_FILE & 0xFF:
+        s = "file read failed"; break;
+    case PF_ERR_WRITE_FILE & 0xFF:
+        s = "file write failed"; break;
+    case PF_ERR_CORRUPT_DIC & 0xFF:
+        s = "corrupted dictionary"; break;
+    case PF_ERR_NOT_SUPPORTED & 0xFF:
+        s = "not supported in this version"; break;
+    case PF_ERR_VERSION_FUTURE & 0xFF:
+        s = "version from future"; break;
+    case PF_ERR_VERSION_PAST & 0xFF:
+        s = "version is obsolete. Rebuild new one."; break;
+    case PF_ERR_COLON_STACK & 0xFF:
+        s = "stack depth changed between : and ; . Probably unbalanced conditional"; break;
+    case PF_ERR_HEADER_ROOM & 0xFF:
+        s = "no room left in header space"; break;
+    case PF_ERR_CODE_ROOM & 0xFF:
+        s = "no room left in code space"; break;
+    case PF_ERR_NO_SHELL & 0xFF:
+        s = "attempt to use names in forth compiled with PF_NO_SHELL"; break;
+    case PF_ERR_NO_NAMES & 0xFF:
+        s = "dictionary has no names";  break;
+    case PF_ERR_OUT_OF_RANGE & 0xFF:
+        s = "parameter out of range";  break;
+    case PF_ERR_ENDIAN_CONFLICT & 0xFF:
+        s = "endian-ness of dictionary does not match code";  break;
+    case PF_ERR_FLOAT_CONFLICT & 0xFF:
+        s = "float support mismatch between .dic file and code";  break;
+    case PF_ERR_CELL_SIZE_CONFLICT & 0xFF:
+        s = "cell size mismatch between .dic file and code";  break;
+    default:
+        s = "unrecognized error code!"; break;
+    }
+    MSG(s);
+    EMIT_CR;
+}
+
+void pfReportThrow( ThrowCode code )
+{
+    const char *s = NULL;
+    switch(code)
+    {
+    case THROW_ABORT:
+    case THROW_ABORT_QUOTE:
+        s = "ABORT"; break;
+    case THROW_STACK_OVERFLOW:
+        s = "Stack overflow!"; break;
+    case THROW_STACK_UNDERFLOW:
+        s = "Stack underflow!"; break;
+    case THROW_EXECUTING:
+        s = "Executing a compile-only word!"; break;
+    case THROW_FLOAT_STACK_UNDERFLOW:
+        s = "Float Stack underflow!"; break;
+    case THROW_UNDEFINED_WORD:
+        s = "Undefined word!"; break;
+    case THROW_PAIRS:
+        s = "Conditional control structure mismatch!"; break;
+    case THROW_BYE:
+    case THROW_QUIT:
+        break;
+    case THROW_SEMICOLON:
+        s = "Stack depth changed between : and ; . Probably unbalanced conditional!"; break;
+    case THROW_DEFERRED:
+        s = "Not a DEFERred word!"; break;
+    default:
+        s = "Unrecognized throw code!"; break;
+    }
+
+    if( s )
+    {
+        MSG_NUM_D("THROW code = ", code );
+        MSG(s);
+        EMIT_CR;
+    }
+}
+#endif
+
+/**************************************************************
+** Copy a Forth String to a 'C' string.
+*/
+
+char *ForthStringToC( char *dst, const char *FString, cell_t dstSize )
+{
+    cell_t Len;
+
+    Len = (cell_t) *FString;
+    /* Make sure the text + NUL can fit. */
+    if( Len >= dstSize )
+    {
+        Len = dstSize - 1;
+    }
+    pfCopyMemory( dst, FString+1, Len );
+    dst[Len] = '\0';
+
+    return dst;
+}
+
+/**************************************************************
+** Copy a NUL terminated string to a Forth counted string.
+*/
+char *CStringToForth( char *dst, const char *CString, cell_t dstSize )
+{
+    cell_t i;
+
+    /* Make sure the SIZE+text can fit. */
+    for( i=1; i<dstSize; i++ )
+    {
+        if( *CString == 0 )
+        {
+            break;
+        }
+        dst[i] = *CString++;
+    }
+    *dst = (char ) i-1;
+    return dst;
+}
+
+/**************************************************************
+** Compare two test strings, case sensitive.
+** Return TRUE if they match.
+*/
+cell_t ffCompareText( const char *s1, const char *s2, cell_t len )
+{
+    cell_t i, Result;
+
+    Result = TRUE;
+    for( i=0; i<len; i++ )
+    {
+DBUGX(("ffCompareText: *s1 = 0x%x, *s2 = 0x%x\n", *s1, *s2 ));
+        if( *s1++ != *s2++ )
+        {
+            Result = FALSE;
+            break;
+        }
+    }
+DBUGX(("ffCompareText: return 0x%x\n", Result ));
+    return Result;
+}
+
+/**************************************************************
+** Compare two test strings, case INsensitive.
+** Return TRUE if they match.
+*/
+cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len )
+{
+    cell_t i, Result;
+    char  c1,c2;
+
+    Result = TRUE;
+    for( i=0; i<len; i++ )
+    {
+        c1 = pfCharToLower(*s1++);
+        c2 = pfCharToLower(*s2++);
+DBUGX(("ffCompareText: c1 = 0x%x, c2 = 0x%x\n", c1, c2 ));
+        if( c1 != c2 )
+        {
+            Result = FALSE;
+            break;
+        }
+    }
+DBUGX(("ffCompareText: return 0x%x\n", Result ));
+    return Result;
+}
+
+/**************************************************************
+** Compare two strings, case sensitive.
+** Return zero if they match, -1 if s1<s2, +1 is s1>s2;
+*/
+cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 )
+{
+    cell_t i, result, n, diff;
+
+    result = 0;
+    n = MIN(len1,len2);
+    for( i=0; i<n; i++ )
+    {
+        if( (diff = (*s2++ - *s1++)) != 0 )
+        {
+            result = (diff > 0) ? -1 : 1 ;
+            break;
+        }
+    }
+    if( result == 0 )  /* Match up to MIN(len1,len2) */
+    {
+        if( len1 < len2 )
+        {
+            result = -1;
+        }
+        else if ( len1 > len2 )
+        {
+            result = 1;
+        }
+    }
+    return result;
+}
+
+/***************************************************************
+** Convert number to text.
+*/
+#define CNTT_PAD_SIZE ((sizeof(cell_t)*8)+2)  /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */
+static char cnttPad[CNTT_PAD_SIZE];
+
+char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars )
+{
+    cell_t IfNegative = 0;
+    char *p,c;
+    ucell_t NewNum, Rem, uNum;
+    cell_t i = 0;
+
+    uNum = Num;
+    if( IfSigned )
+    {
+/* Convert to positive and keep sign. */
+        if( Num < 0 )
+        {
+            IfNegative = TRUE;
+            uNum = -Num;
+        }
+    }
+
+/* Point past end of Pad */
+    p = cnttPad + CNTT_PAD_SIZE;
+    *(--p) = (char) 0; /* NUL terminate */
+
+    while( (i++<MinChars) || (uNum != 0) )
+    {
+        NewNum = uNum / Base;
+        Rem = uNum - (NewNum * Base);
+        c = (char) (( Rem < 10 ) ? (Rem + '0') : (Rem - 10 + 'A'));
+        *(--p) = c;
+        uNum = NewNum;
+    }
+
+    if( IfSigned )
+    {
+        if( IfNegative ) *(--p) = '-';
+    }
+    return p;
+}
+
+/***************************************************************
+** Diagnostic routine that prints memory in table format.
+*/
+void DumpMemory( void *addr, cell_t cnt)
+{
+    cell_t ln, cn, nlines;
+    unsigned char *ptr, *cptr, c;
+
+    nlines = (cnt + 15) / 16;
+
+    ptr = (unsigned char *) addr;
+
+    EMIT_CR;
+
+    for (ln=0; ln<nlines; ln++)
+    {
+        MSG( ConvertNumberToText( (cell_t) ptr, 16, FALSE, 8 ) );
+        MSG(": ");
+        cptr = ptr;
+        for (cn=0; cn<16; cn++)
+        {
+            MSG( ConvertNumberToText( (cell_t) *cptr++, 16, FALSE, 2 ) );
+            EMIT(' ');
+        }
+        EMIT(' ');
+        for (cn=0; cn<16; cn++)
+        {
+            c = *ptr++;
+            if ((c < ' ') || (c > '}')) c = '.';
+            EMIT(c);
+        }
+        EMIT_CR;
+    }
+}
+
+
+/* Print name, mask off any dictionary bits. */
+void TypeName( const char *Name )
+{
+    const char *FirstChar;
+    cell_t Len;
+
+    FirstChar = Name+1;
+    Len = *Name & 0x1F;
+
+    ioType( FirstChar, Len );
+}
+
+
+
+#ifdef PF_UNIT_TEST
+/* Unit test for string conversion routines. */
+#define ASSERT_PAD_IS( index, value, msg ) \
+    if( pad[index] != ((char)(value)) ) \
+    { \
+        ERR(( "ERROR text test failed: " msg "\n")); \
+        numErrors += 1; \
+    } \
+
+cell_t pfUnitTestText( void )
+{
+    cell_t numErrors = 0;
+    char pad[16];
+    char fpad[8];
+
+    /* test CStringToForth */
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    CStringToForth( pad, "frog", 6 );
+    ASSERT_PAD_IS( 0, 4, "CS len 6" );
+    ASSERT_PAD_IS( 4, 'g', "CS end 6" );
+    ASSERT_PAD_IS( 5, 0xA5, "CS past 6" );
+
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    CStringToForth( pad, "frog", 5 );
+    ASSERT_PAD_IS( 0, 4, "CS len 5" );
+    ASSERT_PAD_IS( 4, 'g', "CS end 5" );
+    ASSERT_PAD_IS( 5, 0xA5, "CS past 5" );
+
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    CStringToForth( pad, "frog", 4 );
+    ASSERT_PAD_IS( 0, 3, "CS len 4" );
+    ASSERT_PAD_IS( 3, 'o', "CS end 4" );
+    ASSERT_PAD_IS( 4, 0xA5, "CS past 4" );
+
+    /* Make a Forth string for testing ForthStringToC. */
+    CStringToForth( fpad, "frog", sizeof(fpad) );
+
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    ForthStringToC( pad, fpad, 6 );
+    ASSERT_PAD_IS( 0, 'f', "FS len 6" );
+    ASSERT_PAD_IS( 3, 'g', "FS end 6" );
+    ASSERT_PAD_IS( 4, 0, "FS nul 6" );
+    ASSERT_PAD_IS( 5, 0xA5, "FS past 6" );
+
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    ForthStringToC( pad, fpad, 5 );
+    ASSERT_PAD_IS( 0, 'f', "FS len 5" );
+    ASSERT_PAD_IS( 3, 'g', "FS end 5" );
+    ASSERT_PAD_IS( 4, 0, "FS nul 5" );
+    ASSERT_PAD_IS( 5, 0xA5, "FS past 5" );
+
+    pfSetMemory(pad,0xA5,sizeof(pad));
+    ForthStringToC( pad, fpad, 4 );
+    ASSERT_PAD_IS( 0, 'f', "FS len 4" );
+    ASSERT_PAD_IS( 2, 'o', "FS end 4" );
+    ASSERT_PAD_IS( 3, 0, "FS nul 4" );
+    ASSERT_PAD_IS( 4, 0xA5, "FS past 4" );
+
+    return numErrors;
+}
+#endif

diff --git a/csrc/pf_text.h b/csrc/pf_text.h
index 29e0218..05431d7 100644 (file)
--- a/csrc/pf_text.h
+++ b/csrc/pf_text.h
@@ -1,71 +1,71 @@
-/* @(#) pf_text.h 96/12/18 1.10 */\r
-#ifndef _pforth_text_h\r
-#define _pforth_text_h\r
-\r
-/***************************************************************\r
-** Include file for PForth Text\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#define PF_ERR_INDEX_MASK (0xFFFF)\r
-#define PF_ERR_BASE            (0x80000000)\r
-#define PF_ERR_NO_MEM          (PF_ERR_BASE |  0)\r
-#define PF_ERR_TOO_BIG         (PF_ERR_BASE |  2)\r
-#define PF_ERR_NUM_PARAMS      (PF_ERR_BASE |  3)\r
-#define PF_ERR_OPEN_FILE       (PF_ERR_BASE |  4)\r
-#define PF_ERR_WRONG_FILE      (PF_ERR_BASE |  5)\r
-#define PF_ERR_BAD_FILE        (PF_ERR_BASE |  6)\r
-#define PF_ERR_READ_FILE       (PF_ERR_BASE |  7)\r
-#define PF_ERR_WRITE_FILE      (PF_ERR_BASE |  8)\r
-#define PF_ERR_CORRUPT_DIC     (PF_ERR_BASE |  9)\r
-#define PF_ERR_NOT_SUPPORTED   (PF_ERR_BASE | 10)\r
-#define PF_ERR_VERSION_FUTURE  (PF_ERR_BASE | 11)\r
-#define PF_ERR_VERSION_PAST    (PF_ERR_BASE | 12)\r
-#define PF_ERR_COLON_STACK     (PF_ERR_BASE | 13)\r
-#define PF_ERR_HEADER_ROOM     (PF_ERR_BASE | 14)\r
-#define PF_ERR_CODE_ROOM       (PF_ERR_BASE | 15)\r
-#define PF_ERR_NO_SHELL        (PF_ERR_BASE | 16)\r
-#define PF_ERR_NO_NAMES        (PF_ERR_BASE | 17)\r
-#define PF_ERR_OUT_OF_RANGE    (PF_ERR_BASE | 18)\r
-#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19)\r
-#define PF_ERR_FLOAT_CONFLICT  (PF_ERR_BASE | 20)\r
-#define PF_ERR_CELL_SIZE_CONFLICT (PF_ERR_BASE | 21)\r
-/* If you add an error code here, also add a text message in "pf_text.c". */\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-void pfReportError( const char *FunctionName, Err ErrCode );\r
-void pfReportThrow( ThrowCode code );\r
-\r
-char  *ForthStringToC( char *dst, const char *FString, cell_t dstSize );\r
-char  *CStringToForth( char *dst, const char *CString, cell_t dstSize  );\r
-\r
-cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 );\r
-cell_t ffCompareText( const char *s1, const char *s2, cell_t len );\r
-cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len );\r
-\r
-void  DumpMemory( void *addr, cell_t cnt);\r
-char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars );\r
-void  TypeName( const char *Name );\r
-       \r
-cell_t pfUnitTestText( void );\r
-       \r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pforth_text_h */\r
+/* @(#) pf_text.h 96/12/18 1.10 */
+#ifndef _pforth_text_h
+#define _pforth_text_h
+
+/***************************************************************
+** Include file for PForth Text
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#define PF_ERR_INDEX_MASK (0xFFFF)
+#define PF_ERR_BASE            (0x80000000)
+#define PF_ERR_NO_MEM          (PF_ERR_BASE |  0)
+#define PF_ERR_TOO_BIG         (PF_ERR_BASE |  2)
+#define PF_ERR_NUM_PARAMS      (PF_ERR_BASE |  3)
+#define PF_ERR_OPEN_FILE       (PF_ERR_BASE |  4)
+#define PF_ERR_WRONG_FILE      (PF_ERR_BASE |  5)
+#define PF_ERR_BAD_FILE        (PF_ERR_BASE |  6)
+#define PF_ERR_READ_FILE       (PF_ERR_BASE |  7)
+#define PF_ERR_WRITE_FILE      (PF_ERR_BASE |  8)
+#define PF_ERR_CORRUPT_DIC     (PF_ERR_BASE |  9)
+#define PF_ERR_NOT_SUPPORTED   (PF_ERR_BASE | 10)
+#define PF_ERR_VERSION_FUTURE  (PF_ERR_BASE | 11)
+#define PF_ERR_VERSION_PAST    (PF_ERR_BASE | 12)
+#define PF_ERR_COLON_STACK     (PF_ERR_BASE | 13)
+#define PF_ERR_HEADER_ROOM     (PF_ERR_BASE | 14)
+#define PF_ERR_CODE_ROOM       (PF_ERR_BASE | 15)
+#define PF_ERR_NO_SHELL        (PF_ERR_BASE | 16)
+#define PF_ERR_NO_NAMES        (PF_ERR_BASE | 17)
+#define PF_ERR_OUT_OF_RANGE    (PF_ERR_BASE | 18)
+#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19)
+#define PF_ERR_FLOAT_CONFLICT  (PF_ERR_BASE | 20)
+#define PF_ERR_CELL_SIZE_CONFLICT (PF_ERR_BASE | 21)
+/* If you add an error code here, also add a text message in "pf_text.c". */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void pfReportError( const char *FunctionName, Err ErrCode );
+void pfReportThrow( ThrowCode code );
+
+char  *ForthStringToC( char *dst, const char *FString, cell_t dstSize );
+char  *CStringToForth( char *dst, const char *CString, cell_t dstSize  );
+
+cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 );
+cell_t ffCompareText( const char *s1, const char *s2, cell_t len );
+cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len );
+
+void  DumpMemory( void *addr, cell_t cnt);
+char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars );
+void  TypeName( const char *Name );
+
+cell_t pfUnitTestText( void );
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pforth_text_h */

diff --git a/csrc/pf_types.h b/csrc/pf_types.h
index 95c8e3c..ac4f33b 100644 (file)
--- a/csrc/pf_types.h
+++ b/csrc/pf_types.h
@@ -1,33 +1,33 @@
-/* @(#) pf_types.h 96/12/18 1.3 */\r
-#ifndef _pf_types_h\r
-#define _pf_types_h\r
-\r
-/***************************************************************\r
-** Type declarations for PForth, a Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-/***************************************************************\r
-** Type Declarations\r
-***************************************************************/\r
-\r
-#ifndef Err\r
-       typedef long Err;\r
-#endif\r
-\r
-typedef char  ForthString;\r
-typedef char *ForthStringPtr;\r
-\r
-#endif /* _pf_types_h */\r
+/* @(#) pf_types.h 96/12/18 1.3 */
+#ifndef _pf_types_h
+#define _pf_types_h
+
+/***************************************************************
+** Type declarations for PForth, a Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+/***************************************************************
+** Type Declarations
+***************************************************************/
+
+#ifndef Err
+    typedef long Err;
+#endif
+
+typedef char  ForthString;
+typedef char *ForthStringPtr;
+
+#endif /* _pf_types_h */

diff --git a/csrc/pf_win32.h b/csrc/pf_win32.h
index 6b14ada..1bb298a 100644 (file)
--- a/csrc/pf_win32.h
+++ b/csrc/pf_win32.h
@@ -1,41 +1,41 @@
-/* @(#) pf_win32.h 98/01/26 1.2 */\r
-#ifndef _pf_win32_h\r
-#define _pf_win32_h\r
-\r
-#include <conio.h>\r
-\r
-/***************************************************************\r
-** WIN32 dependant include file for PForth, a Forth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-/* Include as PF_USER_INC2 for PCs */\r
-\r
-/* Modify some existing defines. */\r
-\r
-/*\r
-** The PC will insert LF characters into the dictionary files unless\r
-** we use "b" mode!\r
-*/\r
-#undef PF_FAM_CREATE\r
-#define PF_FAM_CREATE  ("wb+")\r
-\r
-#undef PF_FAM_OPEN_RO\r
-#define PF_FAM_OPEN_RO  ("rb")\r
-\r
-#undef PF_FAM_OPEN_RW\r
-#define PF_FAM_OPEN_RW  ("rb+")\r
-\r
-#endif /* _pf_win32_h */\r
+/* @(#) pf_win32.h 98/01/26 1.2 */
+#ifndef _pf_win32_h
+#define _pf_win32_h
+
+#include <conio.h>
+
+/***************************************************************
+** WIN32 dependant include file for PForth, a Forth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+/* Include as PF_USER_INC2 for PCs */
+
+/* Modify some existing defines. */
+
+/*
+** The PC will insert LF characters into the dictionary files unless
+** we use "b" mode!
+*/
+#undef PF_FAM_CREATE
+#define PF_FAM_CREATE  ("wb+")
+
+#undef PF_FAM_OPEN_RO
+#define PF_FAM_OPEN_RO  ("rb")
+
+#undef PF_FAM_OPEN_RW
+#define PF_FAM_OPEN_RW  ("rb+")
+
+#endif /* _pf_win32_h */

diff --git a/csrc/pf_words.c b/csrc/pf_words.c
index 97760b9..7a753ec 100644 (file)
--- a/csrc/pf_words.c
+++ b/csrc/pf_words.c
@@ -1,223 +1,223 @@
-/* @(#) pf_words.c 96/12/18 1.10 */\r
-/***************************************************************\r
-** Forth words for PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-**\r
-**     941031  rdg             fix ffScan() to look for CRs and LFs\r
-**\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-\r
-\r
-/***************************************************************\r
-** Print number in current base to output stream.\r
-** This version does not handle double precision.\r
-*/\r
-void ffDot( cell_t n )\r
-{\r
-       MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );\r
-       EMIT(' ');\r
-}\r
-\r
-/***************************************************************\r
-** Print number in current base to output stream.\r
-** This version does not handle double precision.\r
-*/\r
-void ffDotHex( cell_t n )\r
-{\r
-       MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );\r
-       EMIT(' ');\r
-}\r
-\r
-/* ( ... --- ... , print stack ) */\r
-void ffDotS( void )\r
-{\r
-       cell_t *sp;\r
-       cell_t i, Depth;\r
-\r
-       MSG("Stack<");\r
-       MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */\r
-       MSG("> ");\r
-       \r
-       Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;\r
-       sp = gCurrentTask->td_StackBase;\r
-       \r
-       if( Depth < 0 )\r
-       {\r
-               MSG("UNDERFLOW!");\r
-       }\r
-       else\r
-       {\r
-               for( i=0; i<Depth; i++ )\r
-               {\r
-/* Print as unsigned if not base 10. */\r
-                       MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );\r
-                       EMIT(' ');\r
-               }\r
-       }\r
-       MSG("\n");\r
-}\r
-\r
-/* ( addr cnt char -- addr' cnt' , skip leading characters ) */\r
-cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
-{\r
-       char *s;\r
-       \r
-       s = AddrIn;\r
-\r
-       if( c == BLANK )\r
-       {\r
-               while( ( Cnt > 0 ) &&\r
-                       (( *s == BLANK) || ( *s == '\t')) )\r
-               {\r
-DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));\r
-                       s++;\r
-                       Cnt--;\r
-               }\r
-       }\r
-       else\r
-       {\r
-               while(( Cnt > 0 ) && ( *s == c ))\r
-               {\r
-DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));\r
-               s++;\r
-               Cnt--;\r
-               }\r
-       }\r
-       *AddrOut = s;\r
-       return Cnt;\r
-}\r
-\r
-/* ( addr cnt char -- addr' cnt' , scan for char ) */\r
-cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )\r
-{\r
-       char *s;\r
-       \r
-       s = AddrIn;\r
-\r
-       if( c == BLANK )\r
-       {\r
-               while(( Cnt > 0 ) &&\r
-                       ( *s != BLANK) &&\r
-                       ( *s != '\r') &&\r
-                       ( *s != '\n') &&\r
-                       ( *s != '\t'))\r
-               {\r
-DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));\r
-                       s++;\r
-                       Cnt--;\r
-               }\r
-       }\r
-       else\r
-       {\r
-               while(( Cnt > 0 ) && ( *s != c ))\r
-               {\r
-DBUGX(("ffScan: %c, %d\n", *s, Cnt ));\r
-                       s++;\r
-                       Cnt--;\r
-               }\r
-       }\r
-       *AddrOut = s;\r
-       return Cnt;\r
-}\r
-\r
-/***************************************************************\r
-** Forth equivalent 'C' functions.\r
-***************************************************************/\r
-\r
-/* Convert a single digit to the corresponding hex number. */\r
-static cell_t HexDigitToNumber( char c )\r
-{      \r
-       if( (c >= '0') && (c <= '9') )\r
-       {\r
-               return( c - '0' );\r
-       }\r
-       else if ( (c >= 'A') && (c <= 'F') )\r
-       {\r
-               return( c - 'A' + 0x0A );\r
-       }\r
-       else\r
-       {\r
-               return -1;\r
-       }\r
-}\r
-\r
-/* Convert a string to the corresponding number using BASE. */\r
-cell_t ffNumberQ( const char *FWord, cell_t *Num )\r
-{\r
-       cell_t Len, i, Accum=0, n, Sign=1;\r
-       const char *s;\r
-       \r
-/* get count */\r
-       Len = *FWord++;\r
-       s = FWord;\r
-\r
-/* process initial minus sign */\r
-       if( *s == '-' )\r
-       {\r
-               Sign = -1;\r
-               s++;\r
-               Len--;\r
-       }\r
-\r
-       for( i=0; i<Len; i++)\r
-       {\r
-               n = HexDigitToNumber( *s++ );\r
-               if( (n < 0) || (n >= gVarBase) )\r
-               {\r
-                       return NUM_TYPE_BAD;\r
-               }\r
-               \r
-               Accum = (Accum * gVarBase) + n;\r
-       }\r
-       *Num = Accum * Sign;\r
-       return NUM_TYPE_SINGLE;\r
-}\r
-\r
-/***************************************************************\r
-** Compiler Support\r
-***************************************************************/\r
-\r
-/* ( char -- c-addr , parse word ) */\r
-char * ffWord( char c )\r
-{\r
-       char *s1,*s2,*s3;\r
-       cell_t n1, n2, n3;\r
-       cell_t i, nc;\r
-\r
-       s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;\r
-       n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;\r
-       n2 = ffSkip( s1, n1, c, &s2 );\r
-DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));\r
-       n3 = ffScan( s2, n2, c, &s3 );\r
-DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));\r
-       nc = n2-n3;\r
-       if (nc > 0)\r
-       {\r
-               gScratch[0] = (char) nc;\r
-               for( i=0; i<nc; i++ )\r
-               {\r
-                       gScratch[i+1] = pfCharToUpper( s2[i] );\r
-               }\r
-       }\r
-       else\r
-       {\r
-       \r
-               gScratch[0] = 0;\r
-       }\r
-       gCurrentTask->td_IN += (n1-n3) + 1;\r
-       return &gScratch[0];\r
-}\r
+/* @(#) pf_words.c 96/12/18 1.10 */
+/***************************************************************
+** Forth words for PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+**
+**  941031  rdg     fix ffScan() to look for CRs and LFs
+**
+***************************************************************/
+
+#include "pf_all.h"
+
+
+/***************************************************************
+** Print number in current base to output stream.
+** This version does not handle double precision.
+*/
+void ffDot( cell_t n )
+{
+    MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
+    EMIT(' ');
+}
+
+/***************************************************************
+** Print number in current base to output stream.
+** This version does not handle double precision.
+*/
+void ffDotHex( cell_t n )
+{
+    MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
+    EMIT(' ');
+}
+
+/* ( ... --- ... , print stack ) */
+void ffDotS( void )
+{
+    cell_t *sp;
+    cell_t i, Depth;
+
+    MSG("Stack<");
+    MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
+    MSG("> ");
+
+    Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
+    sp = gCurrentTask->td_StackBase;
+
+    if( Depth < 0 )
+    {
+        MSG("UNDERFLOW!");
+    }
+    else
+    {
+        for( i=0; i<Depth; i++ )
+        {
+/* Print as unsigned if not base 10. */
+            MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
+            EMIT(' ');
+        }
+    }
+    MSG("\n");
+}
+
+/* ( addr cnt char -- addr' cnt' , skip leading characters ) */
+cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
+{
+    char *s;
+
+    s = AddrIn;
+
+    if( c == BLANK )
+    {
+        while( ( Cnt > 0 ) &&
+            (( *s == BLANK) || ( *s == '\t')) )
+        {
+DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
+            s++;
+            Cnt--;
+        }
+    }
+    else
+    {
+        while(( Cnt > 0 ) && ( *s == c ))
+        {
+DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
+        s++;
+        Cnt--;
+        }
+    }
+    *AddrOut = s;
+    return Cnt;
+}
+
+/* ( addr cnt char -- addr' cnt' , scan for char ) */
+cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
+{
+    char *s;
+
+    s = AddrIn;
+
+    if( c == BLANK )
+    {
+        while(( Cnt > 0 ) &&
+            ( *s != BLANK) &&
+            ( *s != '\r') &&
+            ( *s != '\n') &&
+            ( *s != '\t'))
+        {
+DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
+            s++;
+            Cnt--;
+        }
+    }
+    else
+    {
+        while(( Cnt > 0 ) && ( *s != c ))
+        {
+DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
+            s++;
+            Cnt--;
+        }
+    }
+    *AddrOut = s;
+    return Cnt;
+}
+
+/***************************************************************
+** Forth equivalent 'C' functions.
+***************************************************************/
+
+/* Convert a single digit to the corresponding hex number. */
+static cell_t HexDigitToNumber( char c )
+{
+    if( (c >= '0') && (c <= '9') )
+    {
+        return( c - '0' );
+    }
+    else if ( (c >= 'A') && (c <= 'F') )
+    {
+        return( c - 'A' + 0x0A );
+    }
+    else
+    {
+        return -1;
+    }
+}
+
+/* Convert a string to the corresponding number using BASE. */
+cell_t ffNumberQ( const char *FWord, cell_t *Num )
+{
+    cell_t Len, i, Accum=0, n, Sign=1;
+    const char *s;
+
+/* get count */
+    Len = *FWord++;
+    s = FWord;
+
+/* process initial minus sign */
+    if( *s == '-' )
+    {
+        Sign = -1;
+        s++;
+        Len--;
+    }
+
+    for( i=0; i<Len; i++)
+    {
+        n = HexDigitToNumber( *s++ );
+        if( (n < 0) || (n >= gVarBase) )
+        {
+            return NUM_TYPE_BAD;
+        }
+
+        Accum = (Accum * gVarBase) + n;
+    }
+    *Num = Accum * Sign;
+    return NUM_TYPE_SINGLE;
+}
+
+/***************************************************************
+** Compiler Support
+***************************************************************/
+
+/* ( char -- c-addr , parse word ) */
+char * ffWord( char c )
+{
+    char *s1,*s2,*s3;
+    cell_t n1, n2, n3;
+    cell_t i, nc;
+
+    s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
+    n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
+    n2 = ffSkip( s1, n1, c, &s2 );
+DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));
+    n3 = ffScan( s2, n2, c, &s3 );
+DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));
+    nc = n2-n3;
+    if (nc > 0)
+    {
+        gScratch[0] = (char) nc;
+        for( i=0; i<nc; i++ )
+        {
+            gScratch[i+1] = pfCharToUpper( s2[i] );
+        }
+    }
+    else
+    {
+
+        gScratch[0] = 0;
+    }
+    gCurrentTask->td_IN += (n1-n3) + 1;
+    return &gScratch[0];
+}

diff --git a/csrc/pf_words.h b/csrc/pf_words.h
index edf81a1..d4625f3 100644 (file)
--- a/csrc/pf_words.h
+++ b/csrc/pf_words.h
@@ -1,36 +1,36 @@
-/* @(#) pf_words.h 96/12/18 1.7 */\r
-#ifndef _pforth_words_h\r
-#define _pforth_words_h\r
-\r
-/***************************************************************\r
-** Include file for PForth Words\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-void ffDot( cell_t n );\r
-void ffDotHex( cell_t n );\r
-void ffDotS( void );\r
-cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut );\r
-cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut );\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pforth_words_h */\r
+/* @(#) pf_words.h 96/12/18 1.7 */
+#ifndef _pforth_words_h
+#define _pforth_words_h
+
+/***************************************************************
+** Include file for PForth Words
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void ffDot( cell_t n );
+void ffDotHex( cell_t n );
+void ffDotS( void );
+cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut );
+cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut );
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pforth_words_h */

diff --git a/csrc/pfcompfp.h b/csrc/pfcompfp.h
index 0d8d9d0..f65cbc8 100644 (file)
--- a/csrc/pfcompfp.h
+++ b/csrc/pfcompfp.h
@@ -1,78 +1,78 @@
-/* @(#) pfcompfp.h 96/12/18 1.6 */\r
-/***************************************************************\r
-** Compile FP routines.\r
-** This file is included from "pf_compile.c"\r
-**\r
-** These routines could be left out of an execute only version.\r
-**\r
-** Author: Darren Gibbs, Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-**\r
-***************************************************************/\r
-\r
-\r
-#ifdef PF_SUPPORT_FP\r
-/* Core words */\r
-       CreateDicEntryC( ID_FP_D_TO_F, "D>F", 0 );\r
-       CreateDicEntryC( ID_FP_FSTORE, "F!", 0 );\r
-       CreateDicEntryC( ID_FP_FTIMES, "F*", 0 );\r
-       CreateDicEntryC( ID_FP_FPLUS, "F+", 0 );\r
-       CreateDicEntryC( ID_FP_FMINUS, "F-", 0 );\r
-       CreateDicEntryC( ID_FP_FSLASH, "F/", 0 );\r
-       CreateDicEntryC( ID_FP_F_ZERO_LESS_THAN, "F0<", 0 );\r
-       CreateDicEntryC( ID_FP_F_ZERO_EQUALS, "F0=", 0 );\r
-       CreateDicEntryC( ID_FP_F_LESS_THAN, "F<", 0 );\r
-       CreateDicEntryC( ID_FP_F_TO_D, "F>D", 0 );\r
-       CreateDicEntryC( ID_FP_FFETCH, "F@", 0 );\r
-       CreateDicEntryC( ID_FP_FDEPTH, "FDEPTH", 0 );\r
-       CreateDicEntryC( ID_FP_FDROP, "FDROP", 0 );\r
-       CreateDicEntryC( ID_FP_FDUP, "FDUP", 0 );\r
-       CreateDicEntryC( ID_FP_FLITERAL, "FLITERAL", FLAG_IMMEDIATE );\r
-       CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 );\r
-       CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 );\r
-       CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 );\r
-       CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 );\r
-       CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 );\r
-       CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 );\r
-       CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 );\r
-       CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 );\r
-       CreateDicEntryC( ID_FP_FROT, "FROT", 0 );\r
-       CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 );\r
-       CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 );\r
-       \r
-/* Extended words */\r
-       CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 );\r
-       CreateDicEntryC( ID_FP_FABS, "FABS", 0 );\r
-       CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 );\r
-       CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 );\r
-       CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 );\r
-       CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 );\r
-       CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 );\r
-       CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 );\r
-       CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 );\r
-       CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 );\r
-       CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 );\r
-       CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 );\r
-       CreateDicEntryC( ID_FP_FLN, "FLN", 0 );\r
-       CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 );\r
-       CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 );\r
-       CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 );\r
-       CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 );\r
-       CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 );\r
-       CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 );\r
-       CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 );\r
-       CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 );\r
-       CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 );\r
-\r
-#endif\r
+/* @(#) pfcompfp.h 96/12/18 1.6 */
+/***************************************************************
+** Compile FP routines.
+** This file is included from "pf_compile.c"
+**
+** These routines could be left out of an execute only version.
+**
+** Author: Darren Gibbs, Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+**
+***************************************************************/
+
+
+#ifdef PF_SUPPORT_FP
+/* Core words */
+    CreateDicEntryC( ID_FP_D_TO_F, "D>F", 0 );
+    CreateDicEntryC( ID_FP_FSTORE, "F!", 0 );
+    CreateDicEntryC( ID_FP_FTIMES, "F*", 0 );
+    CreateDicEntryC( ID_FP_FPLUS, "F+", 0 );
+    CreateDicEntryC( ID_FP_FMINUS, "F-", 0 );
+    CreateDicEntryC( ID_FP_FSLASH, "F/", 0 );
+    CreateDicEntryC( ID_FP_F_ZERO_LESS_THAN, "F0<", 0 );
+    CreateDicEntryC( ID_FP_F_ZERO_EQUALS, "F0=", 0 );
+    CreateDicEntryC( ID_FP_F_LESS_THAN, "F<", 0 );
+    CreateDicEntryC( ID_FP_F_TO_D, "F>D", 0 );
+    CreateDicEntryC( ID_FP_FFETCH, "F@", 0 );
+    CreateDicEntryC( ID_FP_FDEPTH, "FDEPTH", 0 );
+    CreateDicEntryC( ID_FP_FDROP, "FDROP", 0 );
+    CreateDicEntryC( ID_FP_FDUP, "FDUP", 0 );
+    CreateDicEntryC( ID_FP_FLITERAL, "FLITERAL", FLAG_IMMEDIATE );
+    CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 );
+    CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 );
+    CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 );
+    CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 );
+    CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 );
+    CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 );
+    CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 );
+    CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 );
+    CreateDicEntryC( ID_FP_FROT, "FROT", 0 );
+    CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 );
+    CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 );
+
+/* Extended words */
+    CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 );
+    CreateDicEntryC( ID_FP_FABS, "FABS", 0 );
+    CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 );
+    CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 );
+    CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 );
+    CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 );
+    CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 );
+    CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 );
+    CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 );
+    CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 );
+    CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 );
+    CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 );
+    CreateDicEntryC( ID_FP_FLN, "FLN", 0 );
+    CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 );
+    CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 );
+    CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 );
+    CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 );
+    CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 );
+    CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 );
+    CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 );
+    CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 );
+    CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 );
+
+#endif

diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c
index bc4c585..9397fa3 100644 (file)
--- a/csrc/pfcompil.c
+++ b/csrc/pfcompil.c
@@ -1,1187 +1,1187 @@
-/* @(#) pfcompil.c 98/01/26 1.5 */\r
-/***************************************************************\r
-** Compiler for PForth based on 'C'\r
-**\r
-** These routines could be left out of an execute only version.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-** 950320 RDG Added underflow checking for FP stack\r
-***************************************************************/\r
-\r
-#include "pf_all.h"\r
-#include "pfcompil.h"\r
-\r
-#define ABORT_RETURN_CODE   (10)\r
-#define UINT32_MASK  ((sizeof(ucell_t)-1))\r
-\r
-/***************************************************************/\r
-/************** Static Prototypes ******************************/\r
-/***************************************************************/\r
-\r
-static void  ffStringColon( const ForthStringPtr FName );\r
-static cell_t CheckRedefinition( const ForthStringPtr FName );\r
-static void  ffUnSmudge( void );\r
-static cell_t FindAndCompile( const char *theWord );\r
-static cell_t ffCheckDicRoom( void );\r
-\r
-#ifndef PF_NO_INIT\r
-       static void CreateDeferredC( ExecToken DefaultXT, const char *CName );\r
-#endif\r
-\r
-cell_t NotCompiled( const char *FunctionName )\r
-{\r
-       MSG("Function ");\r
-       MSG(FunctionName);\r
-       MSG(" not compiled in this version of PForth.\n");\r
-       return -1;\r
-}\r
-\r
-#ifndef PF_NO_SHELL\r
-/***************************************************************\r
-** Create an entry in the Dictionary for the given ExecutionToken.\r
-** FName is name in Forth format.\r
-*/\r
-void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags )\r
-{\r
-       cfNameLinks *cfnl;\r
-\r
-       cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr;\r
-\r
-/* Set link to previous header, if any. */\r
-       if( gVarContext )\r
-       {\r
-               WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) );\r
-       }\r
-       else\r
-       {\r
-               cfnl->cfnl_PreviousName = 0;\r
-       }\r
-\r
-/* Put Execution token in header. */\r
-       WRITE_CELL_DIC( &cfnl->cfnl_ExecToken, XT );\r
-\r
-/* Advance Header Dictionary Pointer */\r
-       gCurrentDictionary->dic_HeaderPtr += sizeof(cfNameLinks);\r
-\r
-/* Laydown name. */\r
-       gVarContext = gCurrentDictionary->dic_HeaderPtr;\r
-       pfCopyMemory( (uint8_t *) gCurrentDictionary->dic_HeaderPtr, FName, (*FName)+1 );\r
-       gCurrentDictionary->dic_HeaderPtr += (*FName)+1;\r
-\r
-/* Set flags. */\r
-       *(char*)gVarContext |= (char) Flags;\r
-       \r
-/* Align to quad byte boundaries with zeroes. */\r
-       while( gCurrentDictionary->dic_HeaderPtr & UINT32_MASK )\r
-       {\r
-               *(char*)(gCurrentDictionary->dic_HeaderPtr++) = 0;\r
-       }\r
-}\r
-\r
-/***************************************************************\r
-** Convert name then create dictionary entry.\r
-*/\r
-void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags )\r
-{\r
-       ForthString FName[40];\r
-       CStringToForth( FName, CName, sizeof(FName) );\r
-       CreateDicEntry( XT, FName, Flags );\r
-}\r
-\r
-/***************************************************************\r
-** Convert absolute namefield address to previous absolute name\r
-** field address or NULL.\r
-*/\r
-const ForthString *NameToPrevious( const ForthString *NFA )\r
-{\r
-       cell_t RelNamePtr;\r
-       const cfNameLinks *cfnl;\r
-\r
-/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */\r
-       cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );\r
-\r
-       RelNamePtr = READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_PreviousName));\r
-/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */\r
-       if( RelNamePtr )\r
-       {\r
-               return ( (ForthString *) NAMEREL_TO_ABS( RelNamePtr ) );\r
-       }\r
-       else\r
-       {\r
-               return NULL;\r
-       }\r
-}\r
-/***************************************************************\r
-** Convert NFA to ExecToken.\r
-*/\r
-ExecToken NameToToken( const ForthString *NFA )\r
-{\r
-       const cfNameLinks *cfnl;\r
-\r
-/* Convert absolute namefield address to absolute link field address. */\r
-       cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );\r
-\r
-       return READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_ExecToken));\r
-}\r
-\r
-/***************************************************************\r
-** Find XTs needed by compiler.\r
-*/\r
-cell_t FindSpecialXTs( void )\r
-{\r
-       if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind;\r
-       if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind;\r
-       if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind;\r
-DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT ));\r
-       return 0;\r
-       \r
-nofind:\r
-       ERR("FindSpecialXTs failed!\n");\r
-       return -1;\r
-}\r
-\r
-/***************************************************************\r
-** Build a dictionary from scratch.\r
-*/\r
-#ifndef PF_NO_INIT\r
-PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )\r
-{\r
-       pfDictionary_t *dic;\r
-\r
-       dic = pfCreateDictionary( HeaderSize, CodeSize );\r
-       if( !dic ) goto nomem;\r
-\r
-       pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n");\r
-       \r
-       gCurrentDictionary = dic;\r
-       gNumPrimitives = NUM_PRIMITIVES;\r
-\r
-       CreateDicEntryC( ID_EXIT, "EXIT", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added EXIT\n");\r
-       CreateDicEntryC( ID_1MINUS, "1-", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added 1-\n");\r
-       CreateDicEntryC( ID_1PLUS, "1+", 0 );\r
-       CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 );\r
-       CreateDicEntryC( ID_2_R_FROM, "2R>", 0 );\r
-       CreateDicEntryC( ID_2_TO_R, "2>R", 0 );\r
-       CreateDicEntryC( ID_2DUP, "2DUP", 0 );\r
-       CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE );\r
-       CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 );\r
-       CreateDicEntryC( ID_2MINUS, "2-", 0 );\r
-       CreateDicEntryC( ID_2PLUS, "2+", 0 );\r
-       CreateDicEntryC( ID_2OVER, "2OVER", 0 );\r
-       CreateDicEntryC( ID_2SWAP, "2SWAP", 0 );\r
-       CreateDicEntryC( ID_ACCEPT_P, "(ACCEPT)", 0 );\r
-       CreateDeferredC( ID_ACCEPT_P, "ACCEPT" );\r
-       CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE );\r
-       CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 );\r
-       CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added ALLOCATE\n");\r
-       CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 );\r
-       CreateDicEntryC( ID_AND, "AND", 0 );\r
-       CreateDicEntryC( ID_BAIL, "BAIL", 0 );\r
-       CreateDicEntryC( ID_BRANCH, "BRANCH", 0 );\r
-       CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 );\r
-       CreateDicEntryC( ID_BYE, "BYE", 0 );\r
-       CreateDicEntryC( ID_CATCH, "CATCH", 0 );\r
-       CreateDicEntryC( ID_CELL, "CELL", 0 );\r
-       CreateDicEntryC( ID_CELLS, "CELLS", 0 );\r
-       CreateDicEntryC( ID_CFETCH, "C@", 0 );\r
-       CreateDicEntryC( ID_CMOVE, "CMOVE", 0 );\r
-       CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 );\r
-       CreateDicEntryC( ID_COLON, ":", 0 );\r
-       CreateDicEntryC( ID_COLON_P, "(:)", 0 );\r
-       CreateDicEntryC( ID_COMPARE, "COMPARE", 0 );\r
-       CreateDicEntryC( ID_COMP_EQUAL, "=", 0 );\r
-       CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 );\r
-       CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 );\r
-       CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added U>\n");\r
-       CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 );\r
-       CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 );\r
-       CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 );\r
-       CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 );\r
-       CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 );\r
-       CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 );\r
-       CreateDicEntryC( ID_CR, "CR", 0 );\r
-       CreateDicEntryC( ID_CREATE, "CREATE", 0 );\r
-       CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 );\r
-       CreateDicEntryC( ID_D_PLUS, "D+", 0 );\r
-       CreateDicEntryC( ID_D_MINUS, "D-", 0 );\r
-       CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 );\r
-       CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 );\r
-       CreateDicEntryC( ID_D_MTIMES, "M*", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added M*\n");\r
-       CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 );\r
-       CreateDicEntryC( ID_DEFER, "DEFER", 0 );\r
-       CreateDicEntryC( ID_CSTORE, "C!", 0 );\r
-       CreateDicEntryC( ID_DEPTH, "DEPTH",  0 );\r
-       pfDebugMessage("pfBuildDictionary: added DEPTH\n");\r
-       CreateDicEntryC( ID_DIVIDE, "/", 0 );\r
-       CreateDicEntryC( ID_DOT, ".",  0 );\r
-       CreateDicEntryC( ID_DOTS, ".S",  0 );\r
-       pfDebugMessage("pfBuildDictionary: added .S\n");\r
-       CreateDicEntryC( ID_DO_P, "(DO)", 0 );\r
-       CreateDicEntryC( ID_DROP, "DROP", 0 );\r
-       CreateDicEntryC( ID_DUMP, "DUMP", 0 );\r
-       CreateDicEntryC( ID_DUP, "DUP",  0 );\r
-       CreateDicEntryC( ID_EMIT_P, "(EMIT)",  0 );\r
-       pfDebugMessage("pfBuildDictionary: added (EMIT)\n");\r
-       CreateDeferredC( ID_EMIT_P, "EMIT");\r
-       pfDebugMessage("pfBuildDictionary: added EMIT\n");\r
-       CreateDicEntryC( ID_EOL, "EOL",  0 );\r
-       CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)",  0 );\r
-       CreateDicEntryC( ID_ERRORQ_P, "?ERROR",  0 );\r
-       CreateDicEntryC( ID_EXECUTE, "EXECUTE",  0 );\r
-       CreateDicEntryC( ID_FETCH, "@",  0 );\r
-       CreateDicEntryC( ID_FILL, "FILL", 0 );\r
-       CreateDicEntryC( ID_FIND, "FIND",  0 );\r
-       CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_DELETE, "DELETE-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_READ, "READ-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE",  0 );\r
-       CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );\r
-       CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );\r
-       CreateDicEntryC( ID_FILE_RO, "R/O",  0 );\r
-       CreateDicEntryC( ID_FILE_RW, "R/W",  0 );\r
-       CreateDicEntryC( ID_FILE_WO, "W/O",  0 );\r
-       CreateDicEntryC( ID_FILE_BIN, "BIN",  0 );\r
-       CreateDicEntryC( ID_FINDNFA, "FINDNFA",  0 );\r
-       CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT",  0 );\r
-       CreateDicEntryC( ID_FREE, "FREE",  0 );\r
-#include "pfcompfp.h"\r
-       CreateDicEntryC( ID_HERE, "HERE",  0 );\r
-       CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)",  0 );\r
-       CreateDicEntryC( ID_I, "I",  0 );\r
-       CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );\r
-       CreateDicEntryC( ID_J, "J",  0 );\r
-       CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE",  0 );\r
-       CreateDicEntryC( ID_KEY, "KEY",  0 );\r
-       CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );\r
-       CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );\r
-       CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );\r
-       CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );\r
-       CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );\r
-       CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );\r
-       CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );\r
-       CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );\r
-       CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );\r
-       CreateDicEntryC( ID_MAX, "MAX", 0 );\r
-       CreateDicEntryC( ID_MIN, "MIN", 0 );\r
-       CreateDicEntryC( ID_MINUS, "-", 0 );\r
-       CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );\r
-       CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );\r
-       CreateDicEntryC( ID_NOOP, "NOOP", 0 );\r
-       CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );\r
-       CreateDicEntryC( ID_OR, "OR", 0 );\r
-       CreateDicEntryC( ID_OVER, "OVER", 0 );\r
-       pfDebugMessage("pfBuildDictionary: added OVER\n");\r
-       CreateDicEntryC( ID_PICK, "PICK",  0 );\r
-       CreateDicEntryC( ID_PLUS, "+",  0 );\r
-       CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );\r
-       CreateDicEntryC( ID_PLUS_STORE, "+!",  0 );\r
-       CreateDicEntryC( ID_QUIT_P, "(QUIT)",  0 );\r
-       CreateDeferredC( ID_QUIT_P, "QUIT" );\r
-       CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );\r
-       CreateDicEntryC( ID_QDUP, "?DUP",  0 );\r
-       CreateDicEntryC( ID_QTERMINAL, "?TERMINAL",  0 );\r
-       CreateDicEntryC( ID_QTERMINAL, "KEY?",  0 );\r
-       CreateDicEntryC( ID_REFILL, "REFILL",  0 );\r
-       CreateDicEntryC( ID_RESIZE, "RESIZE",  0 );\r
-       CreateDicEntryC( ID_ROLL, "ROLL",  0 );\r
-       CreateDicEntryC( ID_ROT, "ROT",  0 );\r
-       CreateDicEntryC( ID_RSHIFT, "RSHIFT",  0 );\r
-       CreateDicEntryC( ID_R_DROP, "RDROP",  0 );\r
-       CreateDicEntryC( ID_R_FETCH, "R@",  0 );\r
-       CreateDicEntryC( ID_R_FROM, "R>",  0 );\r
-       CreateDicEntryC( ID_RP_FETCH, "RP@",  0 );\r
-       CreateDicEntryC( ID_RP_STORE, "RP!",  0 );\r
-       CreateDicEntryC( ID_SEMICOLON, ";",  FLAG_IMMEDIATE );\r
-       CreateDicEntryC( ID_SP_FETCH, "SP@",  0 );\r
-       CreateDicEntryC( ID_SP_STORE, "SP!",  0 );\r
-       CreateDicEntryC( ID_STORE, "!",  0 );\r
-       CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)",  0 );\r
-       CreateDicEntryC( ID_SCAN, "SCAN",  0 );\r
-       CreateDicEntryC( ID_SKIP, "SKIP",  0 );\r
-       CreateDicEntryC( ID_SOURCE, "SOURCE",  0 );\r
-       CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE",  0 );\r
-       CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID",  0 );\r
-       CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID",  0 );\r
-       CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID",  0 );\r
-       CreateDicEntryC( ID_SWAP, "SWAP",  0 );\r
-       CreateDicEntryC( ID_TEST1, "TEST1",  0 );\r
-       CreateDicEntryC( ID_TEST2, "TEST2",  0 );\r
-       CreateDicEntryC( ID_TICK, "'", 0 );\r
-       CreateDicEntryC( ID_TIMES, "*", 0 );\r
-       CreateDicEntryC( ID_THROW, "THROW", 0 );\r
-       CreateDicEntryC( ID_TO_R, ">R", 0 );\r
-       CreateDicEntryC( ID_TYPE, "TYPE", 0 );\r
-       CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );\r
-       CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );\r
-       CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );\r
-       CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );\r
-       CreateDicEntryC( ID_VAR_DP, "DP", 0 );\r
-       CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );\r
-       CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );\r
-       CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );\r
-       CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );\r
-       CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );\r
-       CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );\r
-       CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );\r
-       CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );\r
-       CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );\r
-       CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );\r
-       CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );\r
-       CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );\r
-       CreateDicEntryC( ID_WORD, "WORD", 0 );\r
-       CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );\r
-       CreateDicEntryC( ID_WORD_STORE, "W!", 0 );\r
-       CreateDicEntryC( ID_XOR, "XOR", 0 );\r
-       CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );\r
-       \r
-       pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");\r
-       if( FindSpecialXTs() < 0 ) goto error;\r
-       \r
-       if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */\r
-       \r
-#ifdef PF_DEBUG\r
-       DumpMemory( dic->dic_HeaderBase, 256 );\r
-       DumpMemory( dic->dic_CodeBase, 256 );\r
-#endif\r
-\r
-       pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");\r
-       return (PForthDictionary) dic;\r
-       \r
-error:\r
-       pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");\r
-       pfDeleteDictionary( dic );\r
-       return NULL;\r
-       \r
-nomem:\r
-       return NULL;\r
-}\r
-#endif /* !PF_NO_INIT */\r
-\r
-/*\r
-** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )\r
-** 1 for IMMEDIATE values\r
-*/\r
-cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr )\r
-{\r
-       const ForthString *NameField;\r
-       cell_t Searching = TRUE;\r
-       cell_t Result = 0;\r
-       ExecToken TempXT;\r
-       \r
-       NameField = (ForthString *) gVarContext;\r
-DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));\r
-\r
-       do\r
-       {\r
-               TempXT = NameToToken( NameField );\r
-               \r
-               if( TempXT == XT )\r
-               {\r
-DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));\r
-                       *NFAPtr = NameField ;\r
-                       Result = 1;\r
-                       Searching = FALSE;\r
-               }\r
-               else\r
-               {\r
-                       NameField = NameToPrevious( NameField );\r
-                       if( NameField == NULL )\r
-                       {\r
-                               *NFAPtr = 0;\r
-                               Searching = FALSE;\r
-                       }\r
-               }\r
-       } while ( Searching);\r
-       \r
-       return Result;\r
-}\r
-\r
-/*\r
-** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )\r
-** 1 for IMMEDIATE values\r
-*/\r
-cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )\r
-{\r
-       const ForthString *WordChar;\r
-       uint8_t WordLen;\r
-       const char *NameField, *NameChar;\r
-       int8_t NameLen;\r
-       cell_t Searching = TRUE;\r
-       cell_t Result = 0;\r
-       \r
-       WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F);\r
-       WordChar = WordName+1;\r
-       \r
-       NameField = (ForthString *) gVarContext;\r
-DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));\r
-DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));\r
-       do\r
-       {\r
-               NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE);\r
-               NameChar = NameField+1;\r
-/* DBUG(("   %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */\r
-               if(     ((*NameField & FLAG_SMUDGE) == 0) &&\r
-                       (NameLen == WordLen) &&\r
-                       ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */\r
-               {\r
-DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));\r
-                       *NFAPtr = NameField ;\r
-                       Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;\r
-                       Searching = FALSE;\r
-               }\r
-               else\r
-               {\r
-                       NameField = NameToPrevious( NameField );\r
-                       if( NameField == NULL )\r
-                       {\r
-                               *NFAPtr = WordName;\r
-                               Searching = FALSE;\r
-                       }\r
-               }\r
-       } while ( Searching);\r
-DBUG(("ffFindNFA: returns 0x%x\n", Result));\r
-       return Result;\r
-}\r
-\r
-\r
-/***************************************************************\r
-** ( $name -- $name 0 | xt -1 | xt 1 )\r
-** 1 for IMMEDIATE values\r
-*/\r
-cell_t ffFind( const ForthString *WordName, ExecToken *pXT )\r
-{\r
-       const ForthString *NFA;\r
-       cell_t Result;\r
-       \r
-       Result = ffFindNFA( WordName, &NFA );\r
-DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */\r
-       if( Result )\r
-       {\r
-               *pXT = NameToToken( NFA );\r
-       }\r
-       else\r
-       {\r
-               *pXT = (ExecToken) WordName;\r
-       }\r
-\r
-       return Result;\r
-}\r
-\r
-/****************************************************************\r
-** Find name when passed 'C' string.\r
-*/\r
-cell_t ffFindC( const char *WordName, ExecToken *pXT )\r
-{\r
-DBUG(("ffFindC: %s\n", WordName ));\r
-       CStringToForth( gScratch, WordName, sizeof(gScratch) );\r
-       return ffFind( gScratch, pXT );\r
-}\r
-\r
-\r
-/***********************************************************/\r
-/********* Compiling New Words *****************************/\r
-/***********************************************************/\r
-#define DIC_SAFETY_MARGIN  (400)\r
-\r
-/*************************************************************\r
-**  Check for dictionary overflow. \r
-*/\r
-static cell_t ffCheckDicRoom( void )\r
-{\r
-       cell_t RoomLeft;\r
-       RoomLeft = (char *)gCurrentDictionary->dic_HeaderLimit -\r
-                  (char *)gCurrentDictionary->dic_HeaderPtr;\r
-       if( RoomLeft < DIC_SAFETY_MARGIN )\r
-       {\r
-               pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);\r
-               return PF_ERR_HEADER_ROOM;\r
-       }\r
-\r
-       RoomLeft = (char *)gCurrentDictionary->dic_CodeLimit -\r
-                  (char *)gCurrentDictionary->dic_CodePtr.Byte;\r
-       if( RoomLeft < DIC_SAFETY_MARGIN )\r
-       {\r
-               pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);\r
-               return PF_ERR_CODE_ROOM;\r
-       }\r
-       return 0;\r
-}\r
-\r
-/*************************************************************\r
-**  Create a dictionary entry given a string name. \r
-*/\r
-void ffCreateSecondaryHeader( const ForthStringPtr FName)\r
-{\r
-       pfDebugMessage("ffCreateSecondaryHeader()\n");\r
-/* Check for dictionary overflow. */\r
-       if( ffCheckDicRoom() ) return;\r
-\r
-       pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");\r
-       CheckRedefinition( FName );\r
-/* Align CODE_HERE */\r
-       CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);\r
-       CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );\r
-}\r
-\r
-/*************************************************************\r
-** Begin compiling a secondary word.\r
-*/\r
-static void ffStringColon( const ForthStringPtr FName)\r
-{\r
-       ffCreateSecondaryHeader( FName );\r
-       gVarState = 1;\r
-}\r
-\r
-/*************************************************************\r
-** Read the next ExecToken from the Source and create a word.\r
-*/\r
-void ffColon( void )\r
-{\r
-       char *FName;\r
-       \r
-       gDepthAtColon = DATA_STACK_DEPTH;\r
-       \r
-       FName = ffWord( BLANK );\r
-       if( *FName > 0 )\r
-       {\r
-               ffStringColon( FName );\r
-       }\r
-}\r
-\r
-/*************************************************************\r
-** Check to see if name is already in dictionary.\r
-*/\r
-static cell_t CheckRedefinition( const ForthStringPtr FName )\r
-{\r
-       cell_t flag;\r
-       ExecToken XT;\r
-       \r
-       flag = ffFind( FName, &XT);\r
-       if ( flag && !gVarQuiet)\r
-       {\r
-               ioType( FName+1, (cell_t) *FName );\r
-               MSG( " redefined.\n" ); /* FIXME - allow user to run off this warning. */\r
-       }\r
-       return flag;\r
-}\r
-\r
-void ffStringCreate( char *FName)\r
-{\r
-       ffCreateSecondaryHeader( FName );\r
-       \r
-       CODE_COMMA( ID_CREATE_P );\r
-       CODE_COMMA( ID_EXIT );\r
-       ffFinishSecondary();\r
-       \r
-}\r
-\r
-/* Read the next ExecToken from the Source and create a word. */\r
-void ffCreate( void )\r
-{\r
-       char *FName;\r
-       \r
-       FName = ffWord( BLANK );\r
-       if( *FName > 0 )\r
-       {\r
-               ffStringCreate( FName );\r
-       }\r
-}\r
-\r
-void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )\r
-{\r
-       pfDebugMessage("ffStringDefer()\n");\r
-       ffCreateSecondaryHeader( FName );\r
-       \r
-       CODE_COMMA( ID_DEFER_P );\r
-       CODE_COMMA( DefaultXT );\r
-       \r
-       ffFinishSecondary();\r
-       \r
-}\r
-#ifndef PF_NO_INIT\r
-/* Convert name then create deferred dictionary entry. */\r
-static void CreateDeferredC( ExecToken DefaultXT, const char *CName )\r
-{\r
-       char FName[40];\r
-       CStringToForth( FName, CName, sizeof(FName) );\r
-       ffStringDefer( FName, DefaultXT );\r
-}\r
-#endif\r
-\r
-/* Read the next token from the Source and create a word. */\r
-void ffDefer( void )\r
-{\r
-       char *FName;\r
-       \r
-       FName = ffWord( BLANK );\r
-       if( *FName > 0 )\r
-       {\r
-               ffStringDefer( FName, ID_QUIT_P );\r
-       }\r
-}\r
-\r
-/* Unsmudge the word to make it visible. */\r
-void ffUnSmudge( void )\r
-{\r
-       *(char*)gVarContext &= ~FLAG_SMUDGE;\r
-}\r
-\r
-/* Implement ; */\r
-ThrowCode ffSemiColon( void )\r
-{\r
-       ThrowCode exception = 0;\r
-       gVarState = 0;\r
-       \r
-       if( (gDepthAtColon != DATA_STACK_DEPTH) &&\r
-           (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */\r
-       {\r
-               exception = THROW_SEMICOLON;\r
-       }\r
-       else\r
-       {\r
-               ffFinishSecondary();\r
-       }\r
-       gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
-       return exception;\r
-}\r
-\r
-/* Finish the definition of a Forth word. */\r
-void ffFinishSecondary( void )\r
-{\r
-       CODE_COMMA( ID_EXIT );\r
-       ffUnSmudge();\r
-}\r
-\r
-/**************************************************************/\r
-/* Used to pull a number from the dictionary to the stack */\r
-void ff2Literal( cell_t dHi, cell_t dLo )\r
-{\r
-       CODE_COMMA( ID_2LITERAL_P );\r
-       CODE_COMMA( dHi );\r
-       CODE_COMMA( dLo );\r
-}\r
-void ffALiteral( cell_t Num )\r
-{\r
-       CODE_COMMA( ID_ALITERAL_P );\r
-       CODE_COMMA( Num );\r
-}\r
-void ffLiteral( cell_t Num )\r
-{\r
-       CODE_COMMA( ID_LITERAL_P );\r
-       CODE_COMMA( Num );\r
-}\r
-\r
-#ifdef PF_SUPPORT_FP\r
-void ffFPLiteral( PF_FLOAT fnum )\r
-{\r
-       /* Hack for Metrowerks complier which won't compile the \r
-        * original expression. \r
-        */\r
-       PF_FLOAT  *temp;\r
-       cell_t    *dicPtr;\r
-\r
-/* Make sure that literal float data is float aligned. */\r
-       dicPtr = CODE_HERE + 1;\r
-       while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)\r
-       {\r
-               DBUG((" comma NOOP to align FPLiteral\n"));\r
-               CODE_COMMA( ID_NOOP );\r
-       }\r
-       CODE_COMMA( ID_FP_FLITERAL_P );\r
-\r
-       temp = (PF_FLOAT *)CODE_HERE;\r
-       WRITE_FLOAT_DIC(temp,fnum);   /* Write to dictionary. */\r
-       temp++;\r
-       CODE_HERE = (cell_t *) temp;\r
-}\r
-#endif /* PF_SUPPORT_FP */\r
-\r
-/**************************************************************/\r
-ThrowCode FindAndCompile( const char *theWord )\r
-{\r
-       cell_t Flag;\r
-       ExecToken XT;\r
-       cell_t Num;\r
-       ThrowCode exception = 0;\r
-       \r
-       Flag = ffFind( theWord, &XT);\r
-DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));\r
-\r
-/* Is it a normal word ? */\r
-       if( Flag == -1 )\r
-       {\r
-               if( gVarState )  /* compiling? */\r
-               {\r
-                       CODE_COMMA( XT );\r
-               }\r
-               else\r
-               {\r
-                       exception = pfCatch( XT );\r
-               }\r
-       }\r
-       else if ( Flag == 1 ) /* or is it IMMEDIATE ? */\r
-       {\r
-DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));\r
-               exception = pfCatch( XT );\r
-       }\r
-       else /* try to interpret it as a number. */\r
-       {\r
-/* Call deferred NUMBER? */\r
-               cell_t NumResult;\r
-               \r
-DBUG(("FindAndCompile: not found, try number?\n" ));\r
-               PUSH_DATA_STACK( theWord );   /* Push text of number */\r
-               exception = pfCatch( gNumberQ_XT );\r
-               if( exception ) goto error;\r
-               \r
-DBUG(("FindAndCompile: after number?\n" ));\r
-               NumResult = POP_DATA_STACK;  /* Success? */\r
-               switch( NumResult )\r
-               {\r
-               case NUM_TYPE_SINGLE:\r
-                       if( gVarState )  /* compiling? */\r
-                       {\r
-                               Num = POP_DATA_STACK;\r
-                               ffLiteral( Num );\r
-                       }\r
-                       break;\r
-                       \r
-               case NUM_TYPE_DOUBLE:\r
-                       if( gVarState )  /* compiling? */\r
-                       {\r
-                               Num = POP_DATA_STACK;  /* get hi portion */\r
-                               ff2Literal( Num, POP_DATA_STACK );\r
-                       }\r
-                       break;\r
-\r
-#ifdef PF_SUPPORT_FP\r
-               case NUM_TYPE_FLOAT:\r
-                       if( gVarState )  /* compiling? */\r
-                       {\r
-                               ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );\r
-                       }\r
-                       break;\r
-#endif\r
-\r
-               case NUM_TYPE_BAD:\r
-               default:\r
-                       ioType( theWord+1, *theWord );\r
-                       MSG( "  ? - unrecognized word!\n" );\r
-                       exception = THROW_UNDEFINED_WORD;\r
-                       break;\r
-               \r
-               }\r
-       }\r
-error:\r
-       return exception;\r
-}\r
-\r
-/**************************************************************\r
-** Forth outer interpreter.  Parses words from Source.\r
-** Executes them or compiles them based on STATE.\r
-*/\r
-ThrowCode ffInterpret( void )\r
-{\r
-       cell_t flag;\r
-       char *theWord;\r
-       ThrowCode exception = 0;\r
-       \r
-/* Is there any text left in Source ? */\r
-       while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )\r
-       {\r
-       \r
-               pfDebugMessage("ffInterpret: calling ffWord(()\n");\r
-               theWord = ffWord( BLANK );\r
-               DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));\r
-               \r
-               if( *theWord > 0 )\r
-               {\r
-                       flag = 0;\r
-                       if( gLocalCompiler_XT )\r
-                       {\r
-                               PUSH_DATA_STACK( theWord );   /* Push word. */\r
-                               exception = pfCatch( gLocalCompiler_XT );\r
-                               if( exception ) goto error;\r
-                               flag = POP_DATA_STACK;  /* Compiled local? */\r
-                       }\r
-                       if( flag == 0 )\r
-                       {\r
-                               exception = FindAndCompile( theWord );\r
-                               if( exception ) goto error;\r
-                       }\r
-               }\r
-\r
-               DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,\r
-                       gCurrentTask->td_SourceNum ) );\r
-       }\r
-error:\r
-       return exception;\r
-}\r
-               \r
-/**************************************************************/\r
-ThrowCode ffOK( void )\r
-{\r
-       cell_t exception = 0;\r
-/* Check for stack underflow.   %Q what about overflows? */\r
-       if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 )\r
-       {\r
-               exception = THROW_STACK_UNDERFLOW;\r
-       }\r
-#ifdef PF_SUPPORT_FP  /* Check floating point stack too! */\r
-       else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0)\r
-       {\r
-               exception = THROW_FLOAT_STACK_UNDERFLOW;\r
-       }\r
-#endif\r
-       else if( gCurrentTask->td_InputStream == PF_STDIN)\r
-       {\r
-               if( !gVarState )  /* executing? */\r
-               {\r
-                       if( !gVarQuiet )\r
-                       {\r
-                               MSG( "   ok\n" );\r
-                               if(gVarTraceStack) ffDotS();\r
-                       }\r
-                       else\r
-                       {\r
-                               EMIT_CR;\r
-                       }\r
-               }\r
-       }\r
-       return exception;\r
-}\r
-\r
-/***************************************************************\r
-** Cleanup Include stack by popping and closing files.\r
-***************************************************************/\r
-void pfHandleIncludeError( void )\r
-{\r
-       FileStream *cur;\r
-       \r
-       while( (cur = ffPopInputStream()) != PF_STDIN)\r
-       {\r
-               DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur ));\r
-               sdCloseFile(cur);\r
-       }\r
-}\r
-\r
-/***************************************************************\r
-** Interpret input in a loop.\r
-***************************************************************/\r
-ThrowCode ffOuterInterpreterLoop( void )\r
-{\r
-       cell_t exception = 0;\r
-       do\r
-       {\r
-               exception = ffRefill();\r
-               if(exception <= 0) break;\r
-\r
-               exception = ffInterpret();\r
-               if( exception == 0 )\r
-               {\r
-                       exception = ffOK();\r
-               }\r
-\r
-       } while( exception == 0 );\r
-       return exception;\r
-}\r
-\r
-/***************************************************************\r
-** Include then close a file\r
-***************************************************************/\r
-\r
-ThrowCode ffIncludeFile( FileStream *InputFile )\r
-{\r
-       ThrowCode exception;\r
-       \r
-/* Push file stream. */\r
-       exception = ffPushInputStream( InputFile );\r
-       if( exception < 0 ) return exception;\r
-\r
-/* Run outer interpreter for stream. */\r
-       exception = ffOuterInterpreterLoop();\r
-       if( exception )\r
-       {       \r
-               int i;\r
-/* Report line number and nesting level. */\r
-               MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber);\r
-               MSG(", level = ");  ffDot(gIncludeIndex );\r
-               EMIT_CR\r
-       \r
-/* Dump line of error and show offset in line for >IN */\r
-               for( i=0; i<gCurrentTask->td_SourceNum; i++ )\r
-               {\r
-                       char c = gCurrentTask->td_SourcePtr[i];\r
-                       if( c == '\t' ) c = ' ';\r
-                       EMIT(c);\r
-               }\r
-               EMIT_CR;\r
-               for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^');\r
-               EMIT_CR;\r
-       }\r
-\r
-/* Pop file stream. */\r
-       ffPopInputStream();\r
-       \r
-/* ANSI spec specifies that this should also close the file. */\r
-       sdCloseFile(InputFile);\r
-\r
-       return exception;\r
-}\r
-\r
-#endif /* !PF_NO_SHELL */\r
-\r
-/***************************************************************\r
-** Save current input stream on stack, use this new one.\r
-***************************************************************/\r
-Err ffPushInputStream( FileStream *InputFile )\r
-{\r
-       cell_t Result = 0;\r
-       IncludeFrame *inf;\r
-       \r
-/* Push current input state onto special include stack. */\r
-       if( gIncludeIndex < MAX_INCLUDE_DEPTH )\r
-       {\r
-               inf = &gIncludeStack[gIncludeIndex++];\r
-               inf->inf_FileID = gCurrentTask->td_InputStream;\r
-               inf->inf_IN = gCurrentTask->td_IN;\r
-               inf->inf_LineNumber = gCurrentTask->td_LineNumber;\r
-               inf->inf_SourceNum = gCurrentTask->td_SourceNum;\r
-/* Copy TIB plus any NUL terminator into saved area. */\r
-               if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )\r
-               {\r
-                       pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 );\r
-               }\r
-\r
-/* Set new current input. */\r
-               DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile ));\r
-               gCurrentTask->td_InputStream = InputFile;\r
-               gCurrentTask->td_LineNumber = 0;\r
-       }\r
-       else\r
-       {\r
-               ERR("ffPushInputStream: max depth exceeded.\n");\r
-               return -1;\r
-       }\r
-       \r
-       \r
-       return Result;\r
-}\r
-\r
-/***************************************************************\r
-** Go back to reading previous stream.\r
-** Just return gCurrentTask->td_InputStream upon underflow.\r
-***************************************************************/\r
-FileStream *ffPopInputStream( void )\r
-{\r
-       IncludeFrame *inf;\r
-       FileStream *Result;\r
-       \r
-DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex));\r
-       Result = gCurrentTask->td_InputStream;\r
-       \r
-/* Restore input state. */\r
-       if( gIncludeIndex > 0 )\r
-       {\r
-               inf = &gIncludeStack[--gIncludeIndex];\r
-               gCurrentTask->td_InputStream = inf->inf_FileID;\r
-               DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream ));\r
-               gCurrentTask->td_IN = inf->inf_IN;\r
-               gCurrentTask->td_LineNumber = inf->inf_LineNumber;\r
-               gCurrentTask->td_SourceNum = inf->inf_SourceNum;\r
-/* Copy TIB plus any NUL terminator into saved area. */\r
-               if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )\r
-               {\r
-                       pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 );\r
-               }\r
-\r
-       }\r
-DBUG(("ffPopInputStream: return = 0x%x\n", Result ));\r
-\r
-       return Result;\r
-}\r
-\r
-/***************************************************************\r
-** Convert file pointer to value consistent with SOURCE-ID.\r
-***************************************************************/\r
-cell_t ffConvertStreamToSourceID( FileStream *Stream )\r
-{\r
-       cell_t Result;\r
-       if(Stream == PF_STDIN)\r
-       {\r
-               Result = 0;\r
-       }\r
-       else if(Stream == NULL)\r
-       {\r
-               Result = -1;\r
-       }\r
-       else\r
-       {\r
-               Result = (cell_t) Stream;\r
-       }\r
-       return Result;\r
-}\r
-\r
-/***************************************************************\r
-** Convert file pointer to value consistent with SOURCE-ID.\r
-***************************************************************/\r
-FileStream * ffConvertSourceIDToStream( cell_t id )\r
-{\r
-       FileStream *stream;\r
-       \r
-       if( id == 0 )\r
-       {\r
-               stream = PF_STDIN;\r
-       }\r
-       else if( id == -1 )\r
-       {\r
-               stream = NULL;\r
-       }\r
-       else \r
-       {\r
-               stream = (FileStream *) id;\r
-       }\r
-       return stream;\r
-}\r
-\r
-/**************************************************************\r
-** Receive line from input stream.\r
-** Return length, or -1 for EOF.\r
-*/\r
-#define BACKSPACE  (8)\r
-static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream )\r
-{\r
-       int   c;\r
-       int   len;\r
-       char *p;\r
-       static int lastChar = 0;\r
-       int   done = 0;\r
-\r
-DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream ));\r
-       p = buffer;\r
-       len = 0;\r
-       while( (len < maxChars) && !done )\r
-       {\r
-               c = sdInputChar(stream);\r
-               switch(c)\r
-               {\r
-                       case EOF:\r
-                               DBUG(("EOF\n"));\r
-                               done = 1;\r
-                               if( len <= 0 ) len = -1;\r
-                               break;\r
-                               \r
-                       case '\n':\r
-                               DBUGX(("EOL=\\n\n"));\r
-                               if( lastChar != '\r' ) done = 1;\r
-                               break;\r
-                               \r
-                       case '\r':\r
-                               DBUGX(("EOL=\\r\n"));\r
-                               done = 1;\r
-                               break;\r
-                               \r
-                       default:\r
-                               *p++ = (char) c;\r
-                               len++;\r
-                               break;\r
-               }\r
-               lastChar = c;\r
-       }\r
-\r
-/* NUL terminate line to simplify printing when debugging. */\r
-       if( (len >= 0) && (len < maxChars) ) p[len] = '\0';\r
-               \r
-       return len;\r
-}\r
-\r
-/**************************************************************\r
-** ( -- , fill Source from current stream )\r
-** Return 1 if successful, 0 for EOF, or a negative error.\r
-*/\r
-cell_t ffRefill( void )\r
-{\r
-       cell_t Num;\r
-       cell_t Result = 1;\r
-\r
-/* reset >IN for parser */\r
-       gCurrentTask->td_IN = 0;\r
-\r
-/* get line from current stream */\r
-       if( gCurrentTask->td_InputStream == PF_STDIN )\r
-       {\r
-       /* ACCEPT is deferred so we call it through the dictionary. */\r
-               PUSH_DATA_STACK( gCurrentTask->td_SourcePtr );\r
-               PUSH_DATA_STACK( TIB_SIZE );\r
-               pfCatch( gAcceptP_XT );\r
-               Num = POP_DATA_STACK;\r
-               if( Num < 0 )\r
-               {\r
-                       Result = Num;\r
-                       goto error;\r
-               }\r
-       }\r
-       else\r
-       {\r
-               Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE,\r
-                       gCurrentTask->td_InputStream );\r
-               if( Num == EOF )\r
-               {\r
-                       Result = 0;\r
-                       Num = 0;\r
-               }\r
-       }\r
-\r
-       gCurrentTask->td_SourceNum = Num;\r
-       gCurrentTask->td_LineNumber++;  /* Bump for include. */\r
-       \r
-/* echo input if requested */\r
-       if( gVarEcho && ( Num > 0))\r
-       {\r
-               ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum );\r
-               EMIT_CR;\r
-       }\r
-       \r
-error:\r
-       return Result;\r
-}\r
+/* @(#) pfcompil.c 98/01/26 1.5 */
+/***************************************************************
+** Compiler for PForth based on 'C'
+**
+** These routines could be left out of an execute only version.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+** 950320 RDG Added underflow checking for FP stack
+***************************************************************/
+
+#include "pf_all.h"
+#include "pfcompil.h"
+
+#define ABORT_RETURN_CODE   (10)
+#define UINT32_MASK  ((sizeof(ucell_t)-1))
+
+/***************************************************************/
+/************** Static Prototypes ******************************/
+/***************************************************************/
+
+static void  ffStringColon( const ForthStringPtr FName );
+static cell_t CheckRedefinition( const ForthStringPtr FName );
+static void  ffUnSmudge( void );
+static cell_t FindAndCompile( const char *theWord );
+static cell_t ffCheckDicRoom( void );
+
+#ifndef PF_NO_INIT
+    static void CreateDeferredC( ExecToken DefaultXT, const char *CName );
+#endif
+
+cell_t NotCompiled( const char *FunctionName )
+{
+    MSG("Function ");
+    MSG(FunctionName);
+    MSG(" not compiled in this version of PForth.\n");
+    return -1;
+}
+
+#ifndef PF_NO_SHELL
+/***************************************************************
+** Create an entry in the Dictionary for the given ExecutionToken.
+** FName is name in Forth format.
+*/
+void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags )
+{
+    cfNameLinks *cfnl;
+
+    cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr;
+
+/* Set link to previous header, if any. */
+    if( gVarContext )
+    {
+        WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) );
+    }
+    else
+    {
+        cfnl->cfnl_PreviousName = 0;
+    }
+
+/* Put Execution token in header. */
+    WRITE_CELL_DIC( &cfnl->cfnl_ExecToken, XT );
+
+/* Advance Header Dictionary Pointer */
+    gCurrentDictionary->dic_HeaderPtr += sizeof(cfNameLinks);
+
+/* Laydown name. */
+    gVarContext = gCurrentDictionary->dic_HeaderPtr;
+    pfCopyMemory( (uint8_t *) gCurrentDictionary->dic_HeaderPtr, FName, (*FName)+1 );
+    gCurrentDictionary->dic_HeaderPtr += (*FName)+1;
+
+/* Set flags. */
+    *(char*)gVarContext |= (char) Flags;
+
+/* Align to quad byte boundaries with zeroes. */
+    while( gCurrentDictionary->dic_HeaderPtr & UINT32_MASK )
+    {
+        *(char*)(gCurrentDictionary->dic_HeaderPtr++) = 0;
+    }
+}
+
+/***************************************************************
+** Convert name then create dictionary entry.
+*/
+void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags )
+{
+    ForthString FName[40];
+    CStringToForth( FName, CName, sizeof(FName) );
+    CreateDicEntry( XT, FName, Flags );
+}
+
+/***************************************************************
+** Convert absolute namefield address to previous absolute name
+** field address or NULL.
+*/
+const ForthString *NameToPrevious( const ForthString *NFA )
+{
+    cell_t RelNamePtr;
+    const cfNameLinks *cfnl;
+
+/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */
+    cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
+
+    RelNamePtr = READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_PreviousName));
+/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */
+    if( RelNamePtr )
+    {
+        return ( (ForthString *) NAMEREL_TO_ABS( RelNamePtr ) );
+    }
+    else
+    {
+        return NULL;
+    }
+}
+/***************************************************************
+** Convert NFA to ExecToken.
+*/
+ExecToken NameToToken( const ForthString *NFA )
+{
+    const cfNameLinks *cfnl;
+
+/* Convert absolute namefield address to absolute link field address. */
+    cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
+
+    return READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_ExecToken));
+}
+
+/***************************************************************
+** Find XTs needed by compiler.
+*/
+cell_t FindSpecialXTs( void )
+{
+    if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind;
+    if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind;
+    if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind;
+DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT ));
+    return 0;
+
+nofind:
+    ERR("FindSpecialXTs failed!\n");
+    return -1;
+}
+
+/***************************************************************
+** Build a dictionary from scratch.
+*/
+#ifndef PF_NO_INIT
+PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )
+{
+    pfDictionary_t *dic;
+
+    dic = pfCreateDictionary( HeaderSize, CodeSize );
+    if( !dic ) goto nomem;
+
+    pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n");
+
+    gCurrentDictionary = dic;
+    gNumPrimitives = NUM_PRIMITIVES;
+
+    CreateDicEntryC( ID_EXIT, "EXIT", 0 );
+    pfDebugMessage("pfBuildDictionary: added EXIT\n");
+    CreateDicEntryC( ID_1MINUS, "1-", 0 );
+    pfDebugMessage("pfBuildDictionary: added 1-\n");
+    CreateDicEntryC( ID_1PLUS, "1+", 0 );
+    CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 );
+    CreateDicEntryC( ID_2_R_FROM, "2R>", 0 );
+    CreateDicEntryC( ID_2_TO_R, "2>R", 0 );
+    CreateDicEntryC( ID_2DUP, "2DUP", 0 );
+    CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE );
+    CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 );
+    CreateDicEntryC( ID_2MINUS, "2-", 0 );
+    CreateDicEntryC( ID_2PLUS, "2+", 0 );
+    CreateDicEntryC( ID_2OVER, "2OVER", 0 );
+    CreateDicEntryC( ID_2SWAP, "2SWAP", 0 );
+    CreateDicEntryC( ID_ACCEPT_P, "(ACCEPT)", 0 );
+    CreateDeferredC( ID_ACCEPT_P, "ACCEPT" );
+    CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE );
+    CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 );
+    CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 );
+    pfDebugMessage("pfBuildDictionary: added ALLOCATE\n");
+    CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 );
+    CreateDicEntryC( ID_AND, "AND", 0 );
+    CreateDicEntryC( ID_BAIL, "BAIL", 0 );
+    CreateDicEntryC( ID_BRANCH, "BRANCH", 0 );
+    CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 );
+    CreateDicEntryC( ID_BYE, "BYE", 0 );
+    CreateDicEntryC( ID_CATCH, "CATCH", 0 );
+    CreateDicEntryC( ID_CELL, "CELL", 0 );
+    CreateDicEntryC( ID_CELLS, "CELLS", 0 );
+    CreateDicEntryC( ID_CFETCH, "C@", 0 );
+    CreateDicEntryC( ID_CMOVE, "CMOVE", 0 );
+    CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 );
+    CreateDicEntryC( ID_COLON, ":", 0 );
+    CreateDicEntryC( ID_COLON_P, "(:)", 0 );
+    CreateDicEntryC( ID_COMPARE, "COMPARE", 0 );
+    CreateDicEntryC( ID_COMP_EQUAL, "=", 0 );
+    CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 );
+    CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 );
+    CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 );
+    pfDebugMessage("pfBuildDictionary: added U>\n");
+    CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 );
+    CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 );
+    CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 );
+    CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 );
+    CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 );
+    CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 );
+    CreateDicEntryC( ID_CR, "CR", 0 );
+    CreateDicEntryC( ID_CREATE, "CREATE", 0 );
+    CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 );
+    CreateDicEntryC( ID_D_PLUS, "D+", 0 );
+    CreateDicEntryC( ID_D_MINUS, "D-", 0 );
+    CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 );
+    CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 );
+    CreateDicEntryC( ID_D_MTIMES, "M*", 0 );
+    pfDebugMessage("pfBuildDictionary: added M*\n");
+    CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 );
+    CreateDicEntryC( ID_DEFER, "DEFER", 0 );
+    CreateDicEntryC( ID_CSTORE, "C!", 0 );
+    CreateDicEntryC( ID_DEPTH, "DEPTH",  0 );
+    pfDebugMessage("pfBuildDictionary: added DEPTH\n");
+    CreateDicEntryC( ID_DIVIDE, "/", 0 );
+    CreateDicEntryC( ID_DOT, ".",  0 );
+    CreateDicEntryC( ID_DOTS, ".S",  0 );
+    pfDebugMessage("pfBuildDictionary: added .S\n");
+    CreateDicEntryC( ID_DO_P, "(DO)", 0 );
+    CreateDicEntryC( ID_DROP, "DROP", 0 );
+    CreateDicEntryC( ID_DUMP, "DUMP", 0 );
+    CreateDicEntryC( ID_DUP, "DUP",  0 );
+    CreateDicEntryC( ID_EMIT_P, "(EMIT)",  0 );
+    pfDebugMessage("pfBuildDictionary: added (EMIT)\n");
+    CreateDeferredC( ID_EMIT_P, "EMIT");
+    pfDebugMessage("pfBuildDictionary: added EMIT\n");
+    CreateDicEntryC( ID_EOL, "EOL",  0 );
+    CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)",  0 );
+    CreateDicEntryC( ID_ERRORQ_P, "?ERROR",  0 );
+    CreateDicEntryC( ID_EXECUTE, "EXECUTE",  0 );
+    CreateDicEntryC( ID_FETCH, "@",  0 );
+    CreateDicEntryC( ID_FILL, "FILL", 0 );
+    CreateDicEntryC( ID_FIND, "FIND",  0 );
+    CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE",  0 );
+    CreateDicEntryC( ID_FILE_DELETE, "DELETE-FILE",  0 );
+    CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE",  0 );
+    CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE",  0 );
+    CreateDicEntryC( ID_FILE_READ, "READ-FILE",  0 );
+    CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE",  0 );
+    CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE",  0 );
+    CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );
+    CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );
+    CreateDicEntryC( ID_FILE_RO, "R/O",  0 );
+    CreateDicEntryC( ID_FILE_RW, "R/W",  0 );
+    CreateDicEntryC( ID_FILE_WO, "W/O",  0 );
+    CreateDicEntryC( ID_FILE_BIN, "BIN",  0 );
+    CreateDicEntryC( ID_FINDNFA, "FINDNFA",  0 );
+    CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT",  0 );
+    CreateDicEntryC( ID_FREE, "FREE",  0 );
+#include "pfcompfp.h"
+    CreateDicEntryC( ID_HERE, "HERE",  0 );
+    CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)",  0 );
+    CreateDicEntryC( ID_I, "I",  0 );
+    CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );
+    CreateDicEntryC( ID_J, "J",  0 );
+    CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE",  0 );
+    CreateDicEntryC( ID_KEY, "KEY",  0 );
+    CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );
+    CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );
+    CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );
+    CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );
+    CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );
+    CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );
+    CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );
+    CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );
+    CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );
+    CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );
+    CreateDicEntryC( ID_MAX, "MAX", 0 );
+    CreateDicEntryC( ID_MIN, "MIN", 0 );
+    CreateDicEntryC( ID_MINUS, "-", 0 );
+    CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );
+    CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );
+    CreateDicEntryC( ID_NOOP, "NOOP", 0 );
+    CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );
+    CreateDicEntryC( ID_OR, "OR", 0 );
+    CreateDicEntryC( ID_OVER, "OVER", 0 );
+    pfDebugMessage("pfBuildDictionary: added OVER\n");
+    CreateDicEntryC( ID_PICK, "PICK",  0 );
+    CreateDicEntryC( ID_PLUS, "+",  0 );
+    CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );
+    CreateDicEntryC( ID_PLUS_STORE, "+!",  0 );
+    CreateDicEntryC( ID_QUIT_P, "(QUIT)",  0 );
+    CreateDeferredC( ID_QUIT_P, "QUIT" );
+    CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );
+    CreateDicEntryC( ID_QDUP, "?DUP",  0 );
+    CreateDicEntryC( ID_QTERMINAL, "?TERMINAL",  0 );
+    CreateDicEntryC( ID_QTERMINAL, "KEY?",  0 );
+    CreateDicEntryC( ID_REFILL, "REFILL",  0 );
+    CreateDicEntryC( ID_RESIZE, "RESIZE",  0 );
+    CreateDicEntryC( ID_ROLL, "ROLL",  0 );
+    CreateDicEntryC( ID_ROT, "ROT",  0 );
+    CreateDicEntryC( ID_RSHIFT, "RSHIFT",  0 );
+    CreateDicEntryC( ID_R_DROP, "RDROP",  0 );
+    CreateDicEntryC( ID_R_FETCH, "R@",  0 );
+    CreateDicEntryC( ID_R_FROM, "R>",  0 );
+    CreateDicEntryC( ID_RP_FETCH, "RP@",  0 );
+    CreateDicEntryC( ID_RP_STORE, "RP!",  0 );
+    CreateDicEntryC( ID_SEMICOLON, ";",  FLAG_IMMEDIATE );
+    CreateDicEntryC( ID_SP_FETCH, "SP@",  0 );
+    CreateDicEntryC( ID_SP_STORE, "SP!",  0 );
+    CreateDicEntryC( ID_STORE, "!",  0 );
+    CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)",  0 );
+    CreateDicEntryC( ID_SCAN, "SCAN",  0 );
+    CreateDicEntryC( ID_SKIP, "SKIP",  0 );
+    CreateDicEntryC( ID_SOURCE, "SOURCE",  0 );
+    CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE",  0 );
+    CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID",  0 );
+    CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID",  0 );
+    CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID",  0 );
+    CreateDicEntryC( ID_SWAP, "SWAP",  0 );
+    CreateDicEntryC( ID_TEST1, "TEST1",  0 );
+    CreateDicEntryC( ID_TEST2, "TEST2",  0 );
+    CreateDicEntryC( ID_TICK, "'", 0 );
+    CreateDicEntryC( ID_TIMES, "*", 0 );
+    CreateDicEntryC( ID_THROW, "THROW", 0 );
+    CreateDicEntryC( ID_TO_R, ">R", 0 );
+    CreateDicEntryC( ID_TYPE, "TYPE", 0 );
+    CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );
+    CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );
+    CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );
+    CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );
+    CreateDicEntryC( ID_VAR_DP, "DP", 0 );
+    CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );
+    CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );
+    CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );
+    CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );
+    CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );
+    CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );
+    CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );
+    CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );
+    CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );
+    CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );
+    CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );
+    CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );
+    CreateDicEntryC( ID_WORD, "WORD", 0 );
+    CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );
+    CreateDicEntryC( ID_WORD_STORE, "W!", 0 );
+    CreateDicEntryC( ID_XOR, "XOR", 0 );
+    CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );
+
+    pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");
+    if( FindSpecialXTs() < 0 ) goto error;
+
+    if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */
+
+#ifdef PF_DEBUG
+    DumpMemory( dic->dic_HeaderBase, 256 );
+    DumpMemory( dic->dic_CodeBase, 256 );
+#endif
+
+    pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");
+    return (PForthDictionary) dic;
+
+error:
+    pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");
+    pfDeleteDictionary( dic );
+    return NULL;
+
+nomem:
+    return NULL;
+}
+#endif /* !PF_NO_INIT */
+
+/*
+** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )
+** 1 for IMMEDIATE values
+*/
+cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr )
+{
+    const ForthString *NameField;
+    cell_t Searching = TRUE;
+    cell_t Result = 0;
+    ExecToken TempXT;
+
+    NameField = (ForthString *) gVarContext;
+DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));
+
+    do
+    {
+        TempXT = NameToToken( NameField );
+
+        if( TempXT == XT )
+        {
+DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));
+            *NFAPtr = NameField ;
+            Result = 1;
+            Searching = FALSE;
+        }
+        else
+        {
+            NameField = NameToPrevious( NameField );
+            if( NameField == NULL )
+            {
+                *NFAPtr = 0;
+                Searching = FALSE;
+            }
+        }
+    } while ( Searching);
+
+    return Result;
+}
+
+/*
+** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )
+** 1 for IMMEDIATE values
+*/
+cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )
+{
+    const ForthString *WordChar;
+    uint8_t WordLen;
+    const char *NameField, *NameChar;
+    int8_t NameLen;
+    cell_t Searching = TRUE;
+    cell_t Result = 0;
+
+    WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F);
+    WordChar = WordName+1;
+
+    NameField = (ForthString *) gVarContext;
+DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));
+DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));
+    do
+    {
+        NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE);
+        NameChar = NameField+1;
+/* DBUG(("   %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */
+        if( ((*NameField & FLAG_SMUDGE) == 0) &&
+            (NameLen == WordLen) &&
+            ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */
+        {
+DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));
+            *NFAPtr = NameField ;
+            Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;
+            Searching = FALSE;
+        }
+        else
+        {
+            NameField = NameToPrevious( NameField );
+            if( NameField == NULL )
+            {
+                *NFAPtr = WordName;
+                Searching = FALSE;
+            }
+        }
+    } while ( Searching);
+DBUG(("ffFindNFA: returns 0x%x\n", Result));
+    return Result;
+}
+
+
+/***************************************************************
+** ( $name -- $name 0 | xt -1 | xt 1 )
+** 1 for IMMEDIATE values
+*/
+cell_t ffFind( const ForthString *WordName, ExecToken *pXT )
+{
+    const ForthString *NFA;
+    cell_t Result;
+
+    Result = ffFindNFA( WordName, &NFA );
+DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */
+    if( Result )
+    {
+        *pXT = NameToToken( NFA );
+    }
+    else
+    {
+        *pXT = (ExecToken) WordName;
+    }
+
+    return Result;
+}
+
+/****************************************************************
+** Find name when passed 'C' string.
+*/
+cell_t ffFindC( const char *WordName, ExecToken *pXT )
+{
+DBUG(("ffFindC: %s\n", WordName ));
+    CStringToForth( gScratch, WordName, sizeof(gScratch) );
+    return ffFind( gScratch, pXT );
+}
+
+
+/***********************************************************/
+/********* Compiling New Words *****************************/
+/***********************************************************/
+#define DIC_SAFETY_MARGIN  (400)
+
+/*************************************************************
+**  Check for dictionary overflow.
+*/
+static cell_t ffCheckDicRoom( void )
+{
+    cell_t RoomLeft;
+    RoomLeft = (char *)gCurrentDictionary->dic_HeaderLimit -
+           (char *)gCurrentDictionary->dic_HeaderPtr;
+    if( RoomLeft < DIC_SAFETY_MARGIN )
+    {
+        pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);
+        return PF_ERR_HEADER_ROOM;
+    }
+
+    RoomLeft = (char *)gCurrentDictionary->dic_CodeLimit -
+               (char *)gCurrentDictionary->dic_CodePtr.Byte;
+    if( RoomLeft < DIC_SAFETY_MARGIN )
+    {
+        pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);
+        return PF_ERR_CODE_ROOM;
+    }
+    return 0;
+}
+
+/*************************************************************
+**  Create a dictionary entry given a string name.
+*/
+void ffCreateSecondaryHeader( const ForthStringPtr FName)
+{
+    pfDebugMessage("ffCreateSecondaryHeader()\n");
+/* Check for dictionary overflow. */
+    if( ffCheckDicRoom() ) return;
+
+    pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");
+    CheckRedefinition( FName );
+/* Align CODE_HERE */
+    CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);
+    CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );
+}
+
+/*************************************************************
+** Begin compiling a secondary word.
+*/
+static void ffStringColon( const ForthStringPtr FName)
+{
+    ffCreateSecondaryHeader( FName );
+    gVarState = 1;
+}
+
+/*************************************************************
+** Read the next ExecToken from the Source and create a word.
+*/
+void ffColon( void )
+{
+    char *FName;
+
+    gDepthAtColon = DATA_STACK_DEPTH;
+
+    FName = ffWord( BLANK );
+    if( *FName > 0 )
+    {
+        ffStringColon( FName );
+    }
+}
+
+/*************************************************************
+** Check to see if name is already in dictionary.
+*/
+static cell_t CheckRedefinition( const ForthStringPtr FName )
+{
+    cell_t flag;
+    ExecToken XT;
+
+    flag = ffFind( FName, &XT);
+    if ( flag && !gVarQuiet)
+    {
+        ioType( FName+1, (cell_t) *FName );
+        MSG( " redefined.\n" ); /* FIXME - allow user to run off this warning. */
+    }
+    return flag;
+}
+
+void ffStringCreate( char *FName)
+{
+    ffCreateSecondaryHeader( FName );
+
+    CODE_COMMA( ID_CREATE_P );
+    CODE_COMMA( ID_EXIT );
+    ffFinishSecondary();
+
+}
+
+/* Read the next ExecToken from the Source and create a word. */
+void ffCreate( void )
+{
+    char *FName;
+
+    FName = ffWord( BLANK );
+    if( *FName > 0 )
+    {
+        ffStringCreate( FName );
+    }
+}
+
+void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )
+{
+    pfDebugMessage("ffStringDefer()\n");
+    ffCreateSecondaryHeader( FName );
+
+    CODE_COMMA( ID_DEFER_P );
+    CODE_COMMA( DefaultXT );
+
+    ffFinishSecondary();
+
+}
+#ifndef PF_NO_INIT
+/* Convert name then create deferred dictionary entry. */
+static void CreateDeferredC( ExecToken DefaultXT, const char *CName )
+{
+    char FName[40];
+    CStringToForth( FName, CName, sizeof(FName) );
+    ffStringDefer( FName, DefaultXT );
+}
+#endif
+
+/* Read the next token from the Source and create a word. */
+void ffDefer( void )
+{
+    char *FName;
+
+    FName = ffWord( BLANK );
+    if( *FName > 0 )
+    {
+        ffStringDefer( FName, ID_QUIT_P );
+    }
+}
+
+/* Unsmudge the word to make it visible. */
+void ffUnSmudge( void )
+{
+    *(char*)gVarContext &= ~FLAG_SMUDGE;
+}
+
+/* Implement ; */
+ThrowCode ffSemiColon( void )
+{
+    ThrowCode exception = 0;
+    gVarState = 0;
+
+    if( (gDepthAtColon != DATA_STACK_DEPTH) &&
+        (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */
+    {
+        exception = THROW_SEMICOLON;
+    }
+    else
+    {
+        ffFinishSecondary();
+    }
+    gDepthAtColon = DEPTH_AT_COLON_INVALID;
+    return exception;
+}
+
+/* Finish the definition of a Forth word. */
+void ffFinishSecondary( void )
+{
+    CODE_COMMA( ID_EXIT );
+    ffUnSmudge();
+}
+
+/**************************************************************/
+/* Used to pull a number from the dictionary to the stack */
+void ff2Literal( cell_t dHi, cell_t dLo )
+{
+    CODE_COMMA( ID_2LITERAL_P );
+    CODE_COMMA( dHi );
+    CODE_COMMA( dLo );
+}
+void ffALiteral( cell_t Num )
+{
+    CODE_COMMA( ID_ALITERAL_P );
+    CODE_COMMA( Num );
+}
+void ffLiteral( cell_t Num )
+{
+    CODE_COMMA( ID_LITERAL_P );
+    CODE_COMMA( Num );
+}
+
+#ifdef PF_SUPPORT_FP
+void ffFPLiteral( PF_FLOAT fnum )
+{
+    /* Hack for Metrowerks complier which won't compile the
+     * original expression.
+     */
+    PF_FLOAT  *temp;
+    cell_t    *dicPtr;
+
+/* Make sure that literal float data is float aligned. */
+    dicPtr = CODE_HERE + 1;
+    while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)
+    {
+        DBUG((" comma NOOP to align FPLiteral\n"));
+        CODE_COMMA( ID_NOOP );
+    }
+    CODE_COMMA( ID_FP_FLITERAL_P );
+
+    temp = (PF_FLOAT *)CODE_HERE;
+    WRITE_FLOAT_DIC(temp,fnum);   /* Write to dictionary. */
+    temp++;
+    CODE_HERE = (cell_t *) temp;
+}
+#endif /* PF_SUPPORT_FP */
+
+/**************************************************************/
+ThrowCode FindAndCompile( const char *theWord )
+{
+    cell_t Flag;
+    ExecToken XT;
+    cell_t Num;
+    ThrowCode exception = 0;
+
+    Flag = ffFind( theWord, &XT);
+DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));
+
+/* Is it a normal word ? */
+    if( Flag == -1 )
+    {
+        if( gVarState )  /* compiling? */
+        {
+            CODE_COMMA( XT );
+        }
+        else
+        {
+            exception = pfCatch( XT );
+        }
+    }
+    else if ( Flag == 1 ) /* or is it IMMEDIATE ? */
+    {
+DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));
+        exception = pfCatch( XT );
+    }
+    else /* try to interpret it as a number. */
+    {
+/* Call deferred NUMBER? */
+        cell_t NumResult;
+
+DBUG(("FindAndCompile: not found, try number?\n" ));
+        PUSH_DATA_STACK( theWord );   /* Push text of number */
+        exception = pfCatch( gNumberQ_XT );
+        if( exception ) goto error;
+
+DBUG(("FindAndCompile: after number?\n" ));
+        NumResult = POP_DATA_STACK;  /* Success? */
+        switch( NumResult )
+        {
+        case NUM_TYPE_SINGLE:
+            if( gVarState )  /* compiling? */
+            {
+                Num = POP_DATA_STACK;
+                ffLiteral( Num );
+            }
+            break;
+
+        case NUM_TYPE_DOUBLE:
+            if( gVarState )  /* compiling? */
+            {
+                Num = POP_DATA_STACK;  /* get hi portion */
+                ff2Literal( Num, POP_DATA_STACK );
+            }
+            break;
+
+#ifdef PF_SUPPORT_FP
+        case NUM_TYPE_FLOAT:
+            if( gVarState )  /* compiling? */
+            {
+                ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );
+            }
+            break;
+#endif
+
+        case NUM_TYPE_BAD:
+        default:
+            ioType( theWord+1, *theWord );
+            MSG( "  ? - unrecognized word!\n" );
+            exception = THROW_UNDEFINED_WORD;
+            break;
+
+        }
+    }
+error:
+    return exception;
+}
+
+/**************************************************************
+** Forth outer interpreter.  Parses words from Source.
+** Executes them or compiles them based on STATE.
+*/
+ThrowCode ffInterpret( void )
+{
+    cell_t flag;
+    char *theWord;
+    ThrowCode exception = 0;
+
+/* Is there any text left in Source ? */
+    while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )
+    {
+
+        pfDebugMessage("ffInterpret: calling ffWord(()\n");
+        theWord = ffWord( BLANK );
+        DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));
+
+        if( *theWord > 0 )
+        {
+            flag = 0;
+            if( gLocalCompiler_XT )
+            {
+                PUSH_DATA_STACK( theWord );   /* Push word. */
+                exception = pfCatch( gLocalCompiler_XT );
+                if( exception ) goto error;
+                flag = POP_DATA_STACK;  /* Compiled local? */
+            }
+            if( flag == 0 )
+            {
+                exception = FindAndCompile( theWord );
+                if( exception ) goto error;
+            }
+        }
+
+        DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,
+            gCurrentTask->td_SourceNum ) );
+    }
+error:
+    return exception;
+}
+
+/**************************************************************/
+ThrowCode ffOK( void )
+{
+    cell_t exception = 0;
+/* Check for stack underflow.   %Q what about overflows? */
+    if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 )
+    {
+        exception = THROW_STACK_UNDERFLOW;
+    }
+#ifdef PF_SUPPORT_FP  /* Check floating point stack too! */
+    else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0)
+    {
+        exception = THROW_FLOAT_STACK_UNDERFLOW;
+    }
+#endif
+    else if( gCurrentTask->td_InputStream == PF_STDIN)
+    {
+        if( !gVarState )  /* executing? */
+        {
+            if( !gVarQuiet )
+            {
+                MSG( "   ok\n" );
+                if(gVarTraceStack) ffDotS();
+            }
+            else
+            {
+                EMIT_CR;
+            }
+        }
+    }
+    return exception;
+}
+
+/***************************************************************
+** Cleanup Include stack by popping and closing files.
+***************************************************************/
+void pfHandleIncludeError( void )
+{
+    FileStream *cur;
+
+    while( (cur = ffPopInputStream()) != PF_STDIN)
+    {
+        DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur ));
+        sdCloseFile(cur);
+    }
+}
+
+/***************************************************************
+** Interpret input in a loop.
+***************************************************************/
+ThrowCode ffOuterInterpreterLoop( void )
+{
+    cell_t exception = 0;
+    do
+    {
+        exception = ffRefill();
+        if(exception <= 0) break;
+
+        exception = ffInterpret();
+        if( exception == 0 )
+        {
+            exception = ffOK();
+        }
+
+    } while( exception == 0 );
+    return exception;
+}
+
+/***************************************************************
+** Include then close a file
+***************************************************************/
+
+ThrowCode ffIncludeFile( FileStream *InputFile )
+{
+    ThrowCode exception;
+
+/* Push file stream. */
+    exception = ffPushInputStream( InputFile );
+    if( exception < 0 ) return exception;
+
+/* Run outer interpreter for stream. */
+    exception = ffOuterInterpreterLoop();
+    if( exception )
+    {
+        int i;
+/* Report line number and nesting level. */
+        MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber);
+        MSG(", level = ");  ffDot(gIncludeIndex );
+        EMIT_CR
+
+/* Dump line of error and show offset in line for >IN */
+        for( i=0; i<gCurrentTask->td_SourceNum; i++ )
+        {
+            char c = gCurrentTask->td_SourcePtr[i];
+            if( c == '\t' ) c = ' ';
+            EMIT(c);
+        }
+        EMIT_CR;
+        for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^');
+        EMIT_CR;
+    }
+
+/* Pop file stream. */
+    ffPopInputStream();
+
+/* ANSI spec specifies that this should also close the file. */
+    sdCloseFile(InputFile);
+
+    return exception;
+}
+
+#endif /* !PF_NO_SHELL */
+
+/***************************************************************
+** Save current input stream on stack, use this new one.
+***************************************************************/
+Err ffPushInputStream( FileStream *InputFile )
+{
+    cell_t Result = 0;
+    IncludeFrame *inf;
+
+/* Push current input state onto special include stack. */
+    if( gIncludeIndex < MAX_INCLUDE_DEPTH )
+    {
+        inf = &gIncludeStack[gIncludeIndex++];
+        inf->inf_FileID = gCurrentTask->td_InputStream;
+        inf->inf_IN = gCurrentTask->td_IN;
+        inf->inf_LineNumber = gCurrentTask->td_LineNumber;
+        inf->inf_SourceNum = gCurrentTask->td_SourceNum;
+/* Copy TIB plus any NUL terminator into saved area. */
+        if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
+        {
+            pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 );
+        }
+
+/* Set new current input. */
+        DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile ));
+        gCurrentTask->td_InputStream = InputFile;
+        gCurrentTask->td_LineNumber = 0;
+    }
+    else
+    {
+        ERR("ffPushInputStream: max depth exceeded.\n");
+        return -1;
+    }
+
+
+    return Result;
+}
+
+/***************************************************************
+** Go back to reading previous stream.
+** Just return gCurrentTask->td_InputStream upon underflow.
+***************************************************************/
+FileStream *ffPopInputStream( void )
+{
+    IncludeFrame *inf;
+    FileStream *Result;
+
+DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex));
+    Result = gCurrentTask->td_InputStream;
+
+/* Restore input state. */
+    if( gIncludeIndex > 0 )
+    {
+        inf = &gIncludeStack[--gIncludeIndex];
+        gCurrentTask->td_InputStream = inf->inf_FileID;
+        DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream ));
+        gCurrentTask->td_IN = inf->inf_IN;
+        gCurrentTask->td_LineNumber = inf->inf_LineNumber;
+        gCurrentTask->td_SourceNum = inf->inf_SourceNum;
+/* Copy TIB plus any NUL terminator into saved area. */
+        if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
+        {
+            pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 );
+        }
+
+    }
+DBUG(("ffPopInputStream: return = 0x%x\n", Result ));
+
+    return Result;
+}
+
+/***************************************************************
+** Convert file pointer to value consistent with SOURCE-ID.
+***************************************************************/
+cell_t ffConvertStreamToSourceID( FileStream *Stream )
+{
+    cell_t Result;
+    if(Stream == PF_STDIN)
+    {
+        Result = 0;
+    }
+    else if(Stream == NULL)
+    {
+        Result = -1;
+    }
+    else
+    {
+        Result = (cell_t) Stream;
+    }
+    return Result;
+}
+
+/***************************************************************
+** Convert file pointer to value consistent with SOURCE-ID.
+***************************************************************/
+FileStream * ffConvertSourceIDToStream( cell_t id )
+{
+    FileStream *stream;
+
+    if( id == 0 )
+    {
+        stream = PF_STDIN;
+    }
+    else if( id == -1 )
+    {
+        stream = NULL;
+    }
+    else
+    {
+        stream = (FileStream *) id;
+    }
+    return stream;
+}
+
+/**************************************************************
+** Receive line from input stream.
+** Return length, or -1 for EOF.
+*/
+#define BACKSPACE  (8)
+static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream )
+{
+    int   c;
+    int   len;
+    char *p;
+    static int lastChar = 0;
+    int   done = 0;
+
+DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream ));
+    p = buffer;
+    len = 0;
+    while( (len < maxChars) && !done )
+    {
+        c = sdInputChar(stream);
+        switch(c)
+        {
+            case EOF:
+                DBUG(("EOF\n"));
+                done = 1;
+                if( len <= 0 ) len = -1;
+                break;
+
+            case '\n':
+                DBUGX(("EOL=\\n\n"));
+                if( lastChar != '\r' ) done = 1;
+                break;
+
+            case '\r':
+                DBUGX(("EOL=\\r\n"));
+                done = 1;
+                break;
+
+            default:
+                *p++ = (char) c;
+                len++;
+                break;
+        }
+        lastChar = c;
+    }
+
+/* NUL terminate line to simplify printing when debugging. */
+    if( (len >= 0) && (len < maxChars) ) p[len] = '\0';
+
+    return len;
+}
+
+/**************************************************************
+** ( -- , fill Source from current stream )
+** Return 1 if successful, 0 for EOF, or a negative error.
+*/
+cell_t ffRefill( void )
+{
+    cell_t Num;
+    cell_t Result = 1;
+
+/* reset >IN for parser */
+    gCurrentTask->td_IN = 0;
+
+/* get line from current stream */
+    if( gCurrentTask->td_InputStream == PF_STDIN )
+    {
+    /* ACCEPT is deferred so we call it through the dictionary. */
+        PUSH_DATA_STACK( gCurrentTask->td_SourcePtr );
+        PUSH_DATA_STACK( TIB_SIZE );
+        pfCatch( gAcceptP_XT );
+        Num = POP_DATA_STACK;
+        if( Num < 0 )
+        {
+            Result = Num;
+            goto error;
+        }
+    }
+    else
+    {
+        Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE,
+            gCurrentTask->td_InputStream );
+        if( Num == EOF )
+        {
+            Result = 0;
+            Num = 0;
+        }
+    }
+
+    gCurrentTask->td_SourceNum = Num;
+    gCurrentTask->td_LineNumber++;  /* Bump for include. */
+
+/* echo input if requested */
+    if( gVarEcho && ( Num > 0))
+    {
+        ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum );
+        EMIT_CR;
+    }
+
+error:
+    return Result;
+}

diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h
index 8f27015..3ff831c 100644 (file)
--- a/csrc/pfcompil.h
+++ b/csrc/pfcompil.h
@@ -1,73 +1,73 @@
-/* @(#) pfcompil.h 96/12/18 1.11 */\r
-\r
-#ifndef _pforth_compile_h\r
-#define _pforth_compile_h\r
-\r
-/***************************************************************\r
-** Include file for PForth Compiler\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-Err   ffPushInputStream( FileStream *InputFile );\r
-ExecToken NameToToken( const ForthString *NFA );\r
-FileStream * ffConvertSourceIDToStream( cell_t id );\r
-FileStream *ffPopInputStream( void );\r
-cell_t  ffConvertStreamToSourceID( FileStream *Stream );\r
-cell_t  ffFind( const ForthString *WordName, ExecToken *pXT );\r
-cell_t  ffFindC( const char *WordName, ExecToken *pXT );\r
-cell_t  ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr );\r
-cell_t  ffNumberQ( const char *FWord, cell_t *Num );\r
-cell_t  ffRefill( void );\r
-cell_t  ffTokenToName( ExecToken XT, const ForthString **NFAPtr );\r
-cell_t *NameToCode( ForthString *NFA );\r
-PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );\r
-char *ffWord( char c );\r
-const ForthString *NameToPrevious( const ForthString *NFA );\r
-cell_t FindSpecialCFAs( void );\r
-cell_t FindSpecialXTs( void );\r
-cell_t NotCompiled( const char *FunctionName );\r
-void  CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags );\r
-void  CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags );\r
-void  ff2Literal( cell_t dHi, cell_t dLo );\r
-void  ffALiteral( cell_t Num );\r
-void  ffColon( void );\r
-void  ffCreate( void );\r
-void  ffCreateSecondaryHeader( const ForthStringPtr FName);\r
-void  ffDefer( void );\r
-void  ffFinishSecondary( void );\r
-void  ffLiteral( cell_t Num );\r
-void  ffStringCreate( ForthStringPtr FName);\r
-void  ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT );\r
-void  pfHandleIncludeError( void );\r
-\r
-ThrowCode ffSemiColon( void );\r
-ThrowCode ffOK( void );\r
-ThrowCode ffInterpret( void );\r
-ThrowCode ffOuterInterpreterLoop( void );\r
-ThrowCode ffIncludeFile( FileStream *InputFile );\r
-\r
-#ifdef PF_SUPPORT_FP\r
-void ffFPLiteral( PF_FLOAT fnum );\r
-#endif\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif /* _pforth_compile_h */\r
+/* @(#) pfcompil.h 96/12/18 1.11 */
+
+#ifndef _pforth_compile_h
+#define _pforth_compile_h
+
+/***************************************************************
+** Include file for PForth Compiler
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+Err   ffPushInputStream( FileStream *InputFile );
+ExecToken NameToToken( const ForthString *NFA );
+FileStream * ffConvertSourceIDToStream( cell_t id );
+FileStream *ffPopInputStream( void );
+cell_t  ffConvertStreamToSourceID( FileStream *Stream );
+cell_t  ffFind( const ForthString *WordName, ExecToken *pXT );
+cell_t  ffFindC( const char *WordName, ExecToken *pXT );
+cell_t  ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr );
+cell_t  ffNumberQ( const char *FWord, cell_t *Num );
+cell_t  ffRefill( void );
+cell_t  ffTokenToName( ExecToken XT, const ForthString **NFAPtr );
+cell_t *NameToCode( ForthString *NFA );
+PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );
+char *ffWord( char c );
+const ForthString *NameToPrevious( const ForthString *NFA );
+cell_t FindSpecialCFAs( void );
+cell_t FindSpecialXTs( void );
+cell_t NotCompiled( const char *FunctionName );
+void  CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags );
+void  CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags );
+void  ff2Literal( cell_t dHi, cell_t dLo );
+void  ffALiteral( cell_t Num );
+void  ffColon( void );
+void  ffCreate( void );
+void  ffCreateSecondaryHeader( const ForthStringPtr FName);
+void  ffDefer( void );
+void  ffFinishSecondary( void );
+void  ffLiteral( cell_t Num );
+void  ffStringCreate( ForthStringPtr FName);
+void  ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT );
+void  pfHandleIncludeError( void );
+
+ThrowCode ffSemiColon( void );
+ThrowCode ffOK( void );
+ThrowCode ffInterpret( void );
+ThrowCode ffOuterInterpreterLoop( void );
+ThrowCode ffIncludeFile( FileStream *InputFile );
+
+#ifdef PF_SUPPORT_FP
+void ffFPLiteral( PF_FLOAT fnum );
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pforth_compile_h */

diff --git a/csrc/pfcustom.c b/csrc/pfcustom.c
index 1cacea2..9905348 100644 (file)
--- a/csrc/pfcustom.c
+++ b/csrc/pfcustom.c
@@ -1,121 +1,121 @@
-/* @(#) pfcustom.c 98/01/26 1.3 */\r
-\r
-#ifndef PF_USER_CUSTOM\r
-\r
-/***************************************************************\r
-** Call Custom Functions for pForth\r
-**\r
-** Create a file similar to this and compile it into pForth\r
-** by setting -DPF_USER_CUSTOM="mycustom.c"\r
-**\r
-** Using this, you could, for example, call X11 from Forth.\r
-** See "pf_cglue.c" for more information.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-\r
-#include "pf_all.h"\r
-\r
-static cell_t CTest0( cell_t Val );\r
-static void CTest1( cell_t Val1, cell_t Val2 );\r
-\r
-/****************************************************************\r
-** Step 1: Put your own special glue routines here\r
-**     or link them in from another file or library.\r
-****************************************************************/\r
-static cell_t CTest0( cell_t Val )\r
-{\r
-       MSG_NUM_D("CTest0: Val = ", Val);\r
-       return Val+1;\r
-}\r
-\r
-static void CTest1( cell_t Val1, cell_t Val2 )\r
-{\r
-\r
-       MSG("CTest1: Val1 = "); ffDot(Val1);\r
-       MSG_NUM_D(", Val2 = ", Val2);\r
-}\r
-\r
-/****************************************************************\r
-** Step 2: Create CustomFunctionTable.\r
-**     Do not change the name of CustomFunctionTable!\r
-**     It is used by the pForth kernel.\r
-****************************************************************/\r
-\r
-#ifdef PF_NO_GLOBAL_INIT\r
-/******************\r
-** If your loader does not support global initialization, then you\r
-** must define PF_NO_GLOBAL_INIT and provide a function to fill\r
-** the table. Some embedded system loaders require this!\r
-** Do not change the name of LoadCustomFunctionTable()!\r
-** It is called by the pForth kernel.\r
-*/\r
-#define NUM_CUSTOM_FUNCTIONS  (2)\r
-CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS];\r
-\r
-Err LoadCustomFunctionTable( void )\r
-{\r
-       CustomFunctionTable[0] = CTest0;\r
-       CustomFunctionTable[1] = CTest1;\r
-       return 0;\r
-}\r
-\r
-#else\r
-/******************\r
-** If your loader supports global initialization (most do.) then just\r
-** create the table like this.\r
-*/\r
-CFunc0 CustomFunctionTable[] =\r
-{\r
-       (CFunc0) CTest0,\r
-       (CFunc0) CTest1\r
-};     \r
-#endif\r
-\r
-/****************************************************************\r
-** Step 3: Add custom functions to the dictionary.\r
-**     Do not change the name of CompileCustomFunctions!\r
-**     It is called by the pForth kernel.\r
-****************************************************************/\r
-\r
-#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
-Err CompileCustomFunctions( void )\r
-{\r
-       Err err;\r
-       int i = 0;\r
-/* Compile Forth words that call your custom functions.\r
-** Make sure order of functions matches that in LoadCustomFunctionTable().\r
-** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams\r
-*/\r
-       err = CreateGlueToC( "CTEST0", i++, C_RETURNS_VALUE, 1 );\r
-       if( err < 0 ) return err;\r
-       err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 );\r
-       if( err < 0 ) return err;\r
-       \r
-       return 0;\r
-}\r
-#else\r
-Err CompileCustomFunctions( void ) { return 0; }\r
-#endif\r
-\r
-/****************************************************************\r
-** Step 4: Recompile using compiler option PF_USER_CUSTOM\r
-**         and link with your code.\r
-**         Then rebuild the Forth using "pforth -i system.fth"\r
-**         Test:   10 Ctest0 ( should print message then '11' )\r
-****************************************************************/\r
-\r
-#endif  /* PF_USER_CUSTOM */\r
-\r
+/* @(#) pfcustom.c 98/01/26 1.3 */
+
+#ifndef PF_USER_CUSTOM
+
+/***************************************************************
+** Call Custom Functions for pForth
+**
+** Create a file similar to this and compile it into pForth
+** by setting -DPF_USER_CUSTOM="mycustom.c"
+**
+** Using this, you could, for example, call X11 from Forth.
+** See "pf_cglue.c" for more information.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+
+#include "pf_all.h"
+
+static cell_t CTest0( cell_t Val );
+static void CTest1( cell_t Val1, cell_t Val2 );
+
+/****************************************************************
+** Step 1: Put your own special glue routines here
+**     or link them in from another file or library.
+****************************************************************/
+static cell_t CTest0( cell_t Val )
+{
+    MSG_NUM_D("CTest0: Val = ", Val);
+    return Val+1;
+}
+
+static void CTest1( cell_t Val1, cell_t Val2 )
+{
+
+    MSG("CTest1: Val1 = "); ffDot(Val1);
+    MSG_NUM_D(", Val2 = ", Val2);
+}
+
+/****************************************************************
+** Step 2: Create CustomFunctionTable.
+**     Do not change the name of CustomFunctionTable!
+**     It is used by the pForth kernel.
+****************************************************************/
+
+#ifdef PF_NO_GLOBAL_INIT
+/******************
+** If your loader does not support global initialization, then you
+** must define PF_NO_GLOBAL_INIT and provide a function to fill
+** the table. Some embedded system loaders require this!
+** Do not change the name of LoadCustomFunctionTable()!
+** It is called by the pForth kernel.
+*/
+#define NUM_CUSTOM_FUNCTIONS  (2)
+CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS];
+
+Err LoadCustomFunctionTable( void )
+{
+    CustomFunctionTable[0] = CTest0;
+    CustomFunctionTable[1] = CTest1;
+    return 0;
+}
+
+#else
+/******************
+** If your loader supports global initialization (most do.) then just
+** create the table like this.
+*/
+CFunc0 CustomFunctionTable[] =
+{
+    (CFunc0) CTest0,
+    (CFunc0) CTest1
+};
+#endif
+
+/****************************************************************
+** Step 3: Add custom functions to the dictionary.
+**     Do not change the name of CompileCustomFunctions!
+**     It is called by the pForth kernel.
+****************************************************************/
+
+#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
+Err CompileCustomFunctions( void )
+{
+    Err err;
+    int i = 0;
+/* Compile Forth words that call your custom functions.
+** Make sure order of functions matches that in LoadCustomFunctionTable().
+** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams
+*/
+    err = CreateGlueToC( "CTEST0", i++, C_RETURNS_VALUE, 1 );
+    if( err < 0 ) return err;
+    err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 );
+    if( err < 0 ) return err;
+
+    return 0;
+}
+#else
+Err CompileCustomFunctions( void ) { return 0; }
+#endif
+
+/****************************************************************
+** Step 4: Recompile using compiler option PF_USER_CUSTOM
+**         and link with your code.
+**         Then rebuild the Forth using "pforth -i system.fth"
+**         Test:   10 Ctest0 ( should print message then '11' )
+****************************************************************/
+
+#endif  /* PF_USER_CUSTOM */
+

diff --git a/csrc/pfinnrfp.h b/csrc/pfinnrfp.h
index e6c0104..b74b045 100644 (file)
--- a/csrc/pfinnrfp.h
+++ b/csrc/pfinnrfp.h
@@ -1,336 +1,336 @@
-/*  @(#) pfinnrfp.h 98/02/26 1.4 */\r
-/***************************************************************\r
-** Compile FP routines.\r
-** This file is included from "pf_inner.c"\r
-**\r
-** These routines could be left out of an execute only version.\r
-**\r
-** Author: Darren Gibbs, Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-**\r
-***************************************************************/\r
-\r
-#ifdef PF_SUPPORT_FP\r
-
-#define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*4.0)\r
-\r
-       case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */\r
-               PUSH_FP_TOS;\r
-               Scratch = M_POP; /* dlo */\r
-               DBUG(("dlo = 0x%8x , ", Scratch));\r
-               DBUG(("dhi = 0x%8x\n", TOS));\r
-               \r
-               if( ((TOS ==  0) && (Scratch >= 0)) ||\r
-                   ((TOS == -1) && (Scratch < 0)))\r
-               {\r
-                       /* <=  32 bit precision. */\r
-                       FP_TOS = ((PF_FLOAT) Scratch);  /* Convert dlo and push on FP stack. */\r
-               }\r
-               else /* > 32 bit precision. */\r
-               {\r
-                       fpTemp = ((PF_FLOAT) TOS); /* dhi */\r
-                       fpTemp *= FP_DHI1;\r
-                       fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) );  /* Convert TOS and push on FP stack. */\r
-                       FP_TOS = fpTemp + fpScratch;\r
-               }       \r
-               M_DROP;\r
-               /* printf("d2f = %g\n", FP_TOS); */\r
-               break;\r
-\r
-       case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-               if( IN_CODE_DIC(TOS) )\r
-               {\r
-                       WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );\r
-               }\r
-               else\r
-               {\r
-                       *((PF_FLOAT *) TOS) = FP_TOS;\r
-               }\r
-#else\r
-               *((PF_FLOAT *) TOS) = FP_TOS;\r
-#endif\r
-               M_FP_DROP;              /* drop FP value */\r
-               M_DROP;                 /* drop addr */\r
-               break; \r
-\r
-       case ID_FP_FTIMES:  /* ( F: r1 r2 -- r1*r2 ) */\r
-               FP_TOS = M_FP_POP * FP_TOS;\r
-               break;\r
-\r
-       case ID_FP_FPLUS:  /* ( F: r1 r2 -- r1+r2 ) */\r
-               FP_TOS = M_FP_POP + FP_TOS;\r
-               break;\r
-                       \r
-       case ID_FP_FMINUS:  /* ( F: r1 r2 -- r1-r2 ) */\r
-               FP_TOS = M_FP_POP - FP_TOS;\r
-               break;\r
-\r
-       case ID_FP_FSLASH:  /* ( F: r1 r2 -- r1/r2 ) */\r
-               FP_TOS = M_FP_POP / FP_TOS;\r
-               break;\r
-\r
-       case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag )  ( F: r --  ) */\r
-               PUSH_TOS;\r
-               TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;\r
-               M_FP_DROP;\r
-               break;\r
-\r
-       case ID_FP_F_ZERO_EQUALS: /* ( -- flag )  ( F: r --  ) */\r
-               PUSH_TOS;\r
-               TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;\r
-               M_FP_DROP;\r
-               break;\r
-\r
-       case ID_FP_F_LESS_THAN: /* ( -- flag )  ( F: r1 r2 -- ) */\r
-               PUSH_TOS;\r
-               TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;\r
-               M_FP_DROP;\r
-               break;\r
-               \r
-       case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */\r
-               /* printf("f2d = %g\n", FP_TOS); */\r
-               {\r
-                       ucell_t dlo;\r
-                       cell_t dhi;\r
-                       int ifNeg;\r
-       /* Convert absolute value, then negate D if negative. */\r
-                       PUSH_TOS;   /* Save old TOS */\r
-                       fpTemp = FP_TOS;\r
-                       M_FP_DROP;\r
-                       ifNeg = (fpTemp < 0.0);\r
-                       if( ifNeg )\r
-                       {\r
-                               fpTemp = 0.0 - fpTemp;\r
-                       }\r
-                       fpScratch = fpTemp / FP_DHI1;\r
-               /* printf("f2d - fpScratch = %g\n", fpScratch); */\r
-                       dhi = (cell_t) fpScratch;  /* dhi */\r
-                       fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;\r
-               /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */\r
-               \r
-                       fpTemp = fpTemp - fpScratch; /* Remainder */\r
-                       dlo = (ucell_t) fpTemp;\r
-               /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */\r
-                       if( ifNeg )\r
-                       {\r
-                               dlo = 0 - dlo;\r
-                               dhi = 0 - dhi - 1;\r
-                       }\r
-       /* Push onto stack. */\r
-                       TOS = dlo;\r
-                       PUSH_TOS;\r
-                       TOS = dhi;\r
-               }\r
-               break;\r
-\r
-       case ID_FP_FFETCH:  /* ( addr -- ) ( F: -- r ) */\r
-               PUSH_FP_TOS;\r
-#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
-               if( IN_CODE_DIC(TOS) )\r
-               {\r
-                       FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );\r
-               }\r
-               else\r
-               {\r
-                       FP_TOS = *((PF_FLOAT *) TOS);\r
-               }\r
-#else\r
-               FP_TOS = *((PF_FLOAT *) TOS);\r
-#endif\r
-               M_DROP;\r
-               break;\r
-               \r
-       case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */\r
-               PUSH_TOS;\r
-       /* Add 1 to account for FP_TOS in cached in register. */\r
-               TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);\r
-               break;\r
-               \r
-       case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */\r
-               M_FP_DROP;\r
-               break;\r
-               \r
-       case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */\r
-               PUSH_FP_TOS;\r
-               break;\r
-               \r
-       case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */\r
-               TOS = TOS + sizeof(PF_FLOAT);\r
-               break;\r
-               \r
-       case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */\r
-               TOS = TOS * sizeof(PF_FLOAT);\r
-               break;\r
-               \r
-       case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */\r
-               fpScratch = M_FP_POP;\r
-               FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;\r
-               break;\r
-                \r
-       case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */\r
-               fpScratch = M_FP_POP;\r
-               FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;\r
-               break;\r
-               \r
-       case ID_FP_FNEGATE:\r
-               FP_TOS = -FP_TOS;\r
-               break;\r
-               \r
-       case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */\r
-               PUSH_FP_TOS;\r
-               FP_TOS = M_FP_STACK(1);\r
-               break;\r
-               \r
-       case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */\r
-               fpScratch = M_FP_POP;           /* r2 */\r
-               fpTemp = M_FP_POP;                      /* r1 */\r
-               M_FP_PUSH( fpScratch );         /* r2 */\r
-               PUSH_FP_TOS;                            /* r3 */\r
-               FP_TOS = fpTemp;                        /* r1 */\r
-               break;\r
-               \r
-       case ID_FP_FROUND:\r
-               ERR("\nID_FP_FROUND -  Not Yet!! FIXME\n");\r
-               break;\r
-               \r
-       case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */\r
-               fpScratch = FP_TOS;\r
-               FP_TOS = *FP_STKPTR;\r
-               *FP_STKPTR = fpScratch;\r
-               break;\r
-               \r
-       case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */\r
-               fpScratch = M_FP_POP;\r
-               FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);\r
-               break;\r
-               \r
-       case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */\r
-               FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));\r
-               break;\r
-               \r
-       case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);\r
-               break;\r
-               \r
-       case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */\r
-               FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));\r
-               break;\r
-               \r
-       case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */\r
-               fpTemp = M_FP_POP;\r
-               FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));\r
-               break;\r
-               \r
-       case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );\r
-               break;\r
-               \r
-#ifndef PF_NO_SHELL\r
-       case ID_FP_FLITERAL:\r
-               ffFPLiteral( FP_TOS );\r
-               M_FP_DROP;\r
-               endcase;\r
-#endif  /* !PF_NO_SHELL */\r
-\r
-       case ID_FP_FLITERAL_P:\r
-               PUSH_FP_TOS;\r
-#if 0\r
-/* Some wimpy compilers can't handle this! */\r
-               FP_TOS = *(((PF_FLOAT *)InsPtr)++);\r
-#else\r
-               {\r
-                       PF_FLOAT *fptr;\r
-                       fptr = (PF_FLOAT *)InsPtr;\r
-                       FP_TOS = READ_FLOAT_DIC( fptr++ );\r
-                       InsPtr = (cell_t *) fptr;\r
-               }\r
-#endif\r
-               endcase;\r
-\r
-       case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_log(FP_TOS);\r
-               break;\r
-               \r
-       case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);\r
-               break;\r
-               \r
-       case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */\r
-               M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));\r
-               FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);\r
-               break;\r
-               \r
-       case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );\r
-               break;\r
-               \r
-       case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */\r
-               FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );\r
-               break;\r
-\r
-       case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */\r
-               PUSH_FP_TOS;  /* push cached floats into RAM */\r
-               FP_TOS = FP_STKPTR[TOS];  /* 0 FPICK gets top of FP stack */\r
-               M_DROP;\r
-               break;\r
-               \r
-\r
-#endif\r
+/*  @(#) pfinnrfp.h 98/02/26 1.4 */
+/***************************************************************
+** Compile FP routines.
+** This file is included from "pf_inner.c"
+**
+** These routines could be left out of an execute only version.
+**
+** Author: Darren Gibbs, Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+**
+***************************************************************/
+
+#ifdef PF_SUPPORT_FP
+
+#define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*4.0)
+
+    case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */
+        PUSH_FP_TOS;
+        Scratch = M_POP; /* dlo */
+        DBUG(("dlo = 0x%8x , ", Scratch));
+        DBUG(("dhi = 0x%8x\n", TOS));
+
+        if( ((TOS ==  0) && (Scratch >= 0)) ||
+            ((TOS == -1) && (Scratch < 0)))
+        {
+            /* <=  32 bit precision. */
+            FP_TOS = ((PF_FLOAT) Scratch);  /* Convert dlo and push on FP stack. */
+        }
+        else /* > 32 bit precision. */
+        {
+            fpTemp = ((PF_FLOAT) TOS); /* dhi */
+            fpTemp *= FP_DHI1;
+            fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) );  /* Convert TOS and push on FP stack. */
+            FP_TOS = fpTemp + fpScratch;
+        }
+        M_DROP;
+        /* printf("d2f = %g\n", FP_TOS); */
+        break;
+
+    case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+        if( IN_CODE_DIC(TOS) )
+        {
+            WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
+        }
+        else
+        {
+            *((PF_FLOAT *) TOS) = FP_TOS;
+        }
+#else
+        *((PF_FLOAT *) TOS) = FP_TOS;
+#endif
+        M_FP_DROP;      /* drop FP value */
+        M_DROP;         /* drop addr */
+        break;
+
+    case ID_FP_FTIMES:  /* ( F: r1 r2 -- r1*r2 ) */
+        FP_TOS = M_FP_POP * FP_TOS;
+        break;
+
+    case ID_FP_FPLUS:  /* ( F: r1 r2 -- r1+r2 ) */
+        FP_TOS = M_FP_POP + FP_TOS;
+        break;
+
+    case ID_FP_FMINUS:  /* ( F: r1 r2 -- r1-r2 ) */
+        FP_TOS = M_FP_POP - FP_TOS;
+        break;
+
+    case ID_FP_FSLASH:  /* ( F: r1 r2 -- r1/r2 ) */
+        FP_TOS = M_FP_POP / FP_TOS;
+        break;
+
+    case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag )  ( F: r --  ) */
+        PUSH_TOS;
+        TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
+        M_FP_DROP;
+        break;
+
+    case ID_FP_F_ZERO_EQUALS: /* ( -- flag )  ( F: r --  ) */
+        PUSH_TOS;
+        TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
+        M_FP_DROP;
+        break;
+
+    case ID_FP_F_LESS_THAN: /* ( -- flag )  ( F: r1 r2 -- ) */
+        PUSH_TOS;
+        TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
+        M_FP_DROP;
+        break;
+
+    case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
+        /* printf("f2d = %g\n", FP_TOS); */
+        {
+            ucell_t dlo;
+            cell_t dhi;
+            int ifNeg;
+    /* Convert absolute value, then negate D if negative. */
+            PUSH_TOS;   /* Save old TOS */
+            fpTemp = FP_TOS;
+            M_FP_DROP;
+            ifNeg = (fpTemp < 0.0);
+            if( ifNeg )
+            {
+                fpTemp = 0.0 - fpTemp;
+            }
+            fpScratch = fpTemp / FP_DHI1;
+        /* printf("f2d - fpScratch = %g\n", fpScratch); */
+            dhi = (cell_t) fpScratch;  /* dhi */
+            fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;
+        /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */
+
+            fpTemp = fpTemp - fpScratch; /* Remainder */
+            dlo = (ucell_t) fpTemp;
+        /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
+            if( ifNeg )
+            {
+                dlo = 0 - dlo;
+                dhi = 0 - dhi - 1;
+            }
+    /* Push onto stack. */
+            TOS = dlo;
+            PUSH_TOS;
+            TOS = dhi;
+        }
+        break;
+
+    case ID_FP_FFETCH:  /* ( addr -- ) ( F: -- r ) */
+        PUSH_FP_TOS;
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
+        if( IN_CODE_DIC(TOS) )
+        {
+            FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
+        }
+        else
+        {
+            FP_TOS = *((PF_FLOAT *) TOS);
+        }
+#else
+        FP_TOS = *((PF_FLOAT *) TOS);
+#endif
+        M_DROP;
+        break;
+
+    case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
+        PUSH_TOS;
+    /* Add 1 to account for FP_TOS in cached in register. */
+        TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
+        break;
+
+    case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
+        M_FP_DROP;
+        break;
+
+    case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
+        PUSH_FP_TOS;
+        break;
+
+    case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
+        TOS = TOS + sizeof(PF_FLOAT);
+        break;
+
+    case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
+        TOS = TOS * sizeof(PF_FLOAT);
+        break;
+
+    case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
+        break;
+
+    case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */
+        fpScratch = M_FP_POP;
+        FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;
+        break;
+
+    case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */
+        fpScratch = M_FP_POP;
+        FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;
+        break;
+
+    case ID_FP_FNEGATE:
+        FP_TOS = -FP_TOS;
+        break;
+
+    case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
+        PUSH_FP_TOS;
+        FP_TOS = M_FP_STACK(1);
+        break;
+
+    case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */
+        fpScratch = M_FP_POP;       /* r2 */
+        fpTemp = M_FP_POP;          /* r1 */
+        M_FP_PUSH( fpScratch );     /* r2 */
+        PUSH_FP_TOS;                /* r3 */
+        FP_TOS = fpTemp;            /* r1 */
+        break;
+
+    case ID_FP_FROUND:
+        ERR("\nID_FP_FROUND -  Not Yet!! FIXME\n");
+        break;
+
+    case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */
+        fpScratch = FP_TOS;
+        FP_TOS = *FP_STKPTR;
+        *FP_STKPTR = fpScratch;
+        break;
+
+    case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */
+        fpScratch = M_FP_POP;
+        FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);
+        break;
+
+    case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
+        break;
+
+    case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
+        break;
+
+    case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */
+        /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */
+        FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));
+        break;
+
+    case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
+        break;
+
+    case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
+        break;
+
+    case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */
+        /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */
+        FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));
+        break;
+
+    case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
+        break;
+
+    case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
+        fpTemp = M_FP_POP;
+        FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
+        break;
+
+    case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));
+        break;
+
+    case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
+        break;
+
+    case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
+        break;
+
+#ifndef PF_NO_SHELL
+    case ID_FP_FLITERAL:
+        ffFPLiteral( FP_TOS );
+        M_FP_DROP;
+        endcase;
+#endif  /* !PF_NO_SHELL */
+
+    case ID_FP_FLITERAL_P:
+        PUSH_FP_TOS;
+#if 0
+/* Some wimpy compilers can't handle this! */
+        FP_TOS = *(((PF_FLOAT *)InsPtr)++);
+#else
+        {
+            PF_FLOAT *fptr;
+            fptr = (PF_FLOAT *)InsPtr;
+            FP_TOS = READ_FLOAT_DIC( fptr++ );
+            InsPtr = (cell_t *) fptr;
+        }
+#endif
+        endcase;
+
+    case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
+        break;
+
+    case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
+        break;
+
+    case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
+        break;
+
+    case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
+        break;
+
+    case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
+        M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
+        FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
+        break;
+
+    case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
+        break;
+
+    case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
+        break;
+
+    case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
+        break;
+
+    case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
+        FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
+        break;
+
+    case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
+        PUSH_FP_TOS;  /* push cached floats into RAM */
+        FP_TOS = FP_STKPTR[TOS];  /* 0 FPICK gets top of FP stack */
+        M_DROP;
+        break;
+
+
+#endif

diff --git a/csrc/pforth.h b/csrc/pforth.h
index 70a700a..cd74336 100644 (file)
--- a/csrc/pforth.h
+++ b/csrc/pforth.h
@@ -1,93 +1,93 @@
-/* @(#) pforth.h 98/01/26 1.2 */\r
-#ifndef _pforth_h\r
-#define _pforth_h\r
-\r
-/***************************************************************\r
-** Include file for pForth, a portable Forth based on 'C'\r
-**\r
-** This file is included in any application that uses pForth as a tool.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-**\r
-***************************************************************/\r
-\r
-/* Define stubs for data types so we can pass pointers but not touch inside. */\r
-typedef void *PForthTask;\r
-typedef void *PForthDictionary;\r
-\r
-#include <stdint.h>\r
-/* Integer types for Forth cells, signed and unsigned: */\r
-typedef intptr_t cell_t;\r
-typedef uintptr_t ucell_t;\r
-\r
-typedef ucell_t ExecToken;              /* Execution Token */\r
-typedef cell_t ThrowCode;\r
-\r
-#ifdef __cplusplus\r
-extern "C" {\r
-#endif\r
-\r
-/* Main entry point to pForth. */\r
-cell_t pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit );\r
-\r
-/* Turn off messages. */\r
-void  pfSetQuiet( cell_t IfQuiet );\r
-\r
-/* Query message status. */\r
-cell_t  pfQueryQuiet( void );\r
-\r
-/* Send a message using low level I/O of pForth */\r
-void  pfMessage( const char *CString );\r
-\r
-/* Create a task used to maintain context of execution. */\r
-PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth );\r
-\r
-/* Establish this task as the current task. */\r
-void  pfSetCurrentTask( PForthTask task );\r
-\r
-/* Delete task created by pfCreateTask */\r
-void  pfDeleteTask( PForthTask task );\r
-\r
-/* Build a dictionary with all the basic kernel words. */\r
-PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );\r
-\r
-/* Create an empty dictionary. */\r
-PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize );\r
-\r
-/* Load dictionary from a file. */\r
-PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr );\r
-\r
-/* Load dictionary from static array in "pfdicdat.h". */\r
-PForthDictionary pfLoadStaticDictionary( void );\r
-\r
-/* Delete dictionary data. */\r
-void  pfDeleteDictionary( PForthDictionary dict );\r
-\r
-/* Execute the pForth interpreter. Yes, QUIT is an odd name but it has historical meaning. */\r
-ThrowCode pfQuit( void );\r
-\r
-/* Execute a single execution token in the current task and return 0 or an error code. */\r
-int pfCatch( ExecToken XT );\r
- \r
-/* Include the given pForth source code file. */\r
-ThrowCode pfIncludeFile( const char *FileName );\r
-\r
-/* Execute a Forth word by name. */\r
-ThrowCode  pfExecIfDefined( const char *CString );\r
-\r
-#ifdef __cplusplus\r
-}   \r
-#endif\r
-\r
-#endif  /* _pforth_h */\r
+/* @(#) pforth.h 98/01/26 1.2 */
+#ifndef _pforth_h
+#define _pforth_h
+
+/***************************************************************
+** Include file for pForth, a portable Forth based on 'C'
+**
+** This file is included in any application that uses pForth as a tool.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+**
+***************************************************************/
+
+/* Define stubs for data types so we can pass pointers but not touch inside. */
+typedef void *PForthTask;
+typedef void *PForthDictionary;
+
+#include <stdint.h>
+/* Integer types for Forth cells, signed and unsigned: */
+typedef intptr_t cell_t;
+typedef uintptr_t ucell_t;
+
+typedef ucell_t ExecToken;              /* Execution Token */
+typedef cell_t ThrowCode;
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Main entry point to pForth. */
+cell_t pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit );
+
+/* Turn off messages. */
+void  pfSetQuiet( cell_t IfQuiet );
+
+/* Query message status. */
+cell_t  pfQueryQuiet( void );
+
+/* Send a message using low level I/O of pForth */
+void  pfMessage( const char *CString );
+
+/* Create a task used to maintain context of execution. */
+PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth );
+
+/* Establish this task as the current task. */
+void  pfSetCurrentTask( PForthTask task );
+
+/* Delete task created by pfCreateTask */
+void  pfDeleteTask( PForthTask task );
+
+/* Build a dictionary with all the basic kernel words. */
+PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );
+
+/* Create an empty dictionary. */
+PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize );
+
+/* Load dictionary from a file. */
+PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr );
+
+/* Load dictionary from static array in "pfdicdat.h". */
+PForthDictionary pfLoadStaticDictionary( void );
+
+/* Delete dictionary data. */
+void  pfDeleteDictionary( PForthDictionary dict );
+
+/* Execute the pForth interpreter. Yes, QUIT is an odd name but it has historical meaning. */
+ThrowCode pfQuit( void );
+
+/* Execute a single execution token in the current task and return 0 or an error code. */
+int pfCatch( ExecToken XT );
+
+/* Include the given pForth source code file. */
+ThrowCode pfIncludeFile( const char *FileName );
+
+/* Execute a Forth word by name. */
+ThrowCode  pfExecIfDefined( const char *CString );
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif  /* _pforth_h */

diff --git a/csrc/posix/pf_io_posix.c b/csrc/posix/pf_io_posix.c
index b456788..39ca2a9 100644 (file)
--- a/csrc/posix/pf_io_posix.c
+++ b/csrc/posix/pf_io_posix.c
@@ -1,141 +1,141 @@
-/* $Id$ */\r
-/***************************************************************\r
-** I/O subsystem for PForth based on 'C'\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-** 090220 PLB Fixed broken sdQueryTerminal on Mac. It always returned true.\r
-***************************************************************/\r
-\r
-#include "../pf_all.h"\r
-\r
-/* Configure console so that characters are not buffered.\r
- * This allows KEY and ?TERMINAL to work and also HISTORY.ON\r
- */\r
-\r
-#include <unistd.h>\r
-#include <sys/time.h>\r
-#ifdef sun\r
-#include <sys/int_types.h> /* Needed on Solaris for uint32_t in termio.h */\r
-#endif\r
-#include <termios.h>\r
-#include <sys/poll.h>\r
-\r
-static struct termios save_termios;\r
-static int stdin_is_tty;\r
-\r
-/* poll() is broken in Mac OS X Tiger OS so use select() instead. */\r
-#ifndef PF_USE_SELECT\r
-#define PF_USE_SELECT  (1)\r
-#endif\r
-\r
-/* Default portable terminal I/O. */\r
-int  sdTerminalOut( char c )\r
-{\r
-       return putchar(c);\r
-}\r
-\r
-int  sdTerminalEcho( char c )\r
-{\r
-       putchar(c);\r
-       return 0;\r
-}\r
-\r
-int  sdTerminalIn( void )\r
-{\r
-       return getchar();\r
-}\r
-\r
-int  sdTerminalFlush( void )\r
-{\r
-#ifdef PF_NO_FILEIO\r
-       return -1;\r
-#else\r
-       return fflush(PF_STDOUT);\r
-#endif\r
-}\r
-\r
-/****************************************************/\r
-int sdQueryTerminal( void )\r
-{\r
-#if PF_USE_SELECT\r
-       int select_retval;\r
-       fd_set readfds;\r
-       struct timeval tv;\r
-       FD_ZERO(&readfds);\r
-       FD_SET(STDIN_FILENO, &readfds);\r
-       /* Set timeout to zero so that we just poll and return. */\r
-       tv.tv_sec = 0;\r
-       tv.tv_usec = 0;\r
-       select_retval = select(STDIN_FILENO+1, &readfds, NULL, NULL, &tv);\r
-       if (select_retval < 0)\r
-       {\r
-               perror("sdTerminalInit: select");\r
-       }\r
-       return FD_ISSET(STDIN_FILENO,&readfds) ? FTRUE : FFALSE;\r
-\r
-#else\r
-       int result;\r
-       struct pollfd  pfd = { 0 };\r
-       sdTerminalFlush();\r
-       pfd.fd = STDIN_FILENO;\r
-       pfd.events = POLLIN;\r
-       result = poll( &pfd, 1, 0 );\r
-    /* On a Mac it may set revents to POLLNVAL because poll() is broken on Tiger. */\r
-       if( pfd.revents & POLLNVAL )\r
-       {\r
-               PRT(("sdQueryTerminal: poll got POLLNVAL, stdin not open\n"));\r
-               return FFALSE;\r
-       }\r
-       else\r
-       {\r
-               return (pfd.revents & POLLIN) ? FTRUE : FFALSE;\r
-       }\r
-#endif\r
-}\r
-\r
-/****************************************************/\r
-void sdTerminalInit(void)\r
-{\r
-       struct termios term;\r
-\r
-       stdin_is_tty = isatty(STDIN_FILENO);\r
-       if (stdin_is_tty)\r
-       {               \r
-/* Get current terminal attributes and save them so we can restore them. */\r
-               tcgetattr(STDIN_FILENO, &term);\r
-               save_termios = term;\r
-       \r
-/* ICANON says to wait upon read until a character is received,\r
- * and then to return it immediately (or soon enough....)\r
- * ECHOCTL says not to echo backspaces and other control chars as ^H */\r
-               term.c_lflag &= ~( ECHO | ECHONL | ECHOCTL | ICANON );\r
-               term.c_cc[VTIME] = 0;\r
-               term.c_cc[VMIN] = 1;\r
-               if( tcsetattr(STDIN_FILENO, TCSANOW, &term) < 0 )\r
-               {\r
-                       perror("sdTerminalInit: tcsetattr");\r
-               }\r
-       }\r
-}\r
-\r
-/****************************************************/\r
-void sdTerminalTerm(void)\r
-{\r
-       if (stdin_is_tty)\r
-       {\r
-               tcsetattr(STDIN_FILENO, TCSANOW, &save_termios);\r
-       }\r
-}\r
+/* $Id$ */
+/***************************************************************
+** I/O subsystem for PForth based on 'C'
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+** 090220 PLB Fixed broken sdQueryTerminal on Mac. It always returned true.
+***************************************************************/
+
+#include "../pf_all.h"
+
+/* Configure console so that characters are not buffered.
+ * This allows KEY and ?TERMINAL to work and also HISTORY.ON
+ */
+
+#include <unistd.h>
+#include <sys/time.h>
+#ifdef sun
+#include <sys/int_types.h> /* Needed on Solaris for uint32_t in termio.h */
+#endif
+#include <termios.h>
+#include <sys/poll.h>
+
+static struct termios save_termios;
+static int stdin_is_tty;
+
+/* poll() is broken in Mac OS X Tiger OS so use select() instead. */
+#ifndef PF_USE_SELECT
+#define PF_USE_SELECT  (1)
+#endif
+
+/* Default portable terminal I/O. */
+int  sdTerminalOut( char c )
+{
+    return putchar(c);
+}
+
+int  sdTerminalEcho( char c )
+{
+    putchar(c);
+    return 0;
+}
+
+int  sdTerminalIn( void )
+{
+    return getchar();
+}
+
+int  sdTerminalFlush( void )
+{
+#ifdef PF_NO_FILEIO
+    return -1;
+#else
+    return fflush(PF_STDOUT);
+#endif
+}
+
+/****************************************************/
+int sdQueryTerminal( void )
+{
+#if PF_USE_SELECT
+    int select_retval;
+    fd_set readfds;
+    struct timeval tv;
+    FD_ZERO(&readfds);
+    FD_SET(STDIN_FILENO, &readfds);
+    /* Set timeout to zero so that we just poll and return. */
+    tv.tv_sec = 0;
+    tv.tv_usec = 0;
+    select_retval = select(STDIN_FILENO+1, &readfds, NULL, NULL, &tv);
+    if (select_retval < 0)
+    {
+        perror("sdTerminalInit: select");
+    }
+    return FD_ISSET(STDIN_FILENO,&readfds) ? FTRUE : FFALSE;
+
+#else
+    int result;
+    struct pollfd  pfd = { 0 };
+    sdTerminalFlush();
+    pfd.fd = STDIN_FILENO;
+    pfd.events = POLLIN;
+    result = poll( &pfd, 1, 0 );
+    /* On a Mac it may set revents to POLLNVAL because poll() is broken on Tiger. */
+    if( pfd.revents & POLLNVAL )
+    {
+        PRT(("sdQueryTerminal: poll got POLLNVAL, stdin not open\n"));
+        return FFALSE;
+    }
+    else
+    {
+        return (pfd.revents & POLLIN) ? FTRUE : FFALSE;
+    }
+#endif
+}
+
+/****************************************************/
+void sdTerminalInit(void)
+{
+    struct termios term;
+
+    stdin_is_tty = isatty(STDIN_FILENO);
+    if (stdin_is_tty)
+    {
+/* Get current terminal attributes and save them so we can restore them. */
+        tcgetattr(STDIN_FILENO, &term);
+        save_termios = term;
+
+/* ICANON says to wait upon read until a character is received,
+ * and then to return it immediately (or soon enough....)
+ * ECHOCTL says not to echo backspaces and other control chars as ^H */
+        term.c_lflag &= ~( ECHO | ECHONL | ECHOCTL | ICANON );
+        term.c_cc[VTIME] = 0;
+        term.c_cc[VMIN] = 1;
+        if( tcsetattr(STDIN_FILENO, TCSANOW, &term) < 0 )
+        {
+            perror("sdTerminalInit: tcsetattr");
+        }
+    }
+}
+
+/****************************************************/
+void sdTerminalTerm(void)
+{
+    if (stdin_is_tty)
+    {
+        tcsetattr(STDIN_FILENO, TCSANOW, &save_termios);
+    }
+}

diff --git a/csrc/stdio/pf_io_stdio.c b/csrc/stdio/pf_io_stdio.c
index 75decfc..6d70a6b 100644 (file)
--- a/csrc/stdio/pf_io_stdio.c
+++ b/csrc/stdio/pf_io_stdio.c
@@ -1,57 +1,57 @@
-/* $Id$ */\r
-/***************************************************************\r
-** I/O subsystem for PForth for common systems.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-***************************************************************/\r
-\r
-#include "../pf_all.h"\r
-\r
-/* Default portable terminal I/O. */\r
-int  sdTerminalOut( char c )\r
-{\r
-       return putchar(c);\r
-}\r
-/* We don't need to echo because getchar() echos. */\r
-int  sdTerminalEcho( char c )\r
-{\r
-       return 0;\r
-}\r
-int  sdTerminalIn( void )\r
-{\r
-       return getchar();\r
-}\r
-int  sdQueryTerminal( void )\r
-{\r
-       return 0;\r
-}\r
-\r
-int  sdTerminalFlush( void )\r
-{\r
-#ifdef PF_NO_FILEIO\r
-       return -1;\r
-#else\r
-       return fflush(PF_STDOUT);\r
-#endif\r
-}\r
-\r
-void sdTerminalInit( void )\r
-{\r
-}\r
-void sdTerminalTerm( void )\r
-{\r
-}\r
-\r
+/* $Id$ */
+/***************************************************************
+** I/O subsystem for PForth for common systems.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+***************************************************************/
+
+#include "../pf_all.h"
+
+/* Default portable terminal I/O. */
+int  sdTerminalOut( char c )
+{
+    return putchar(c);
+}
+/* We don't need to echo because getchar() echos. */
+int  sdTerminalEcho( char c )
+{
+    return 0;
+}
+int  sdTerminalIn( void )
+{
+    return getchar();
+}
+int  sdQueryTerminal( void )
+{
+    return 0;
+}
+
+int  sdTerminalFlush( void )
+{
+#ifdef PF_NO_FILEIO
+    return -1;
+#else
+    return fflush(PF_STDOUT);
+#endif
+}
+
+void sdTerminalInit( void )
+{
+}
+void sdTerminalTerm( void )
+{
+}
+

diff --git a/csrc/win32/pf_io_win32.c b/csrc/win32/pf_io_win32.c
index 6fd93e3..2d75822 100644 (file)
--- a/csrc/win32/pf_io_win32.c
+++ b/csrc/win32/pf_io_win32.c
@@ -1,72 +1,72 @@
-/* $Id$ */\r
-/***************************************************************\r
-** I/O subsystem for PForth for WIN32 systems.\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-****************************************************************\r
-** 941004 PLB Extracted IO calls from pforth_main.c\r
-***************************************************************/\r
-\r
-#include "../pf_all.h"\r
-\r
-#include <conio.h>\r
-\r
-/* Use console mode I/O so that KEY and ?TERMINAL will work. */\r
-#if defined(WIN32) || defined(__NT__)\r
-int  sdTerminalOut( char c )\r
-{\r
-#if defined(__WATCOMC__)\r
-       return putch((char)(c));\r
-#else\r
-       return _putch((char)(c));\r
-#endif\r
-}\r
-\r
-/* Needed cuz _getch() does not echo. */\r
-int  sdTerminalEcho( char c )\r
-{\r
-#if defined(__WATCOMC__)\r
-       return putch((char)(c));\r
-#else\r
-       return _putch((char)(c));\r
-#endif\r
-}\r
-\r
-int  sdTerminalIn( void )\r
-{\r
-       return _getch();\r
-}\r
-\r
-int  sdQueryTerminal( void )\r
-{\r
-       return _kbhit();\r
-}\r
-\r
-int  sdTerminalFlush( void )\r
-{\r
-#ifdef PF_NO_FILEIO\r
-       return -1;\r
-#else\r
-       return fflush(PF_STDOUT);\r
-#endif\r
-}\r
-\r
-void sdTerminalInit( void )\r
-{\r
-}\r
-\r
-void sdTerminalTerm( void )\r
-{\r
-}\r
-#endif\r
+/* $Id$ */
+/***************************************************************
+** I/O subsystem for PForth for WIN32 systems.
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+****************************************************************
+** 941004 PLB Extracted IO calls from pforth_main.c
+***************************************************************/
+
+#include "../pf_all.h"
+
+#include <conio.h>
+
+/* Use console mode I/O so that KEY and ?TERMINAL will work. */
+#if defined(WIN32) || defined(__NT__)
+int  sdTerminalOut( char c )
+{
+#if defined(__WATCOMC__)
+    return putch((char)(c));
+#else
+    return _putch((char)(c));
+#endif
+}
+
+/* Needed cuz _getch() does not echo. */
+int  sdTerminalEcho( char c )
+{
+#if defined(__WATCOMC__)
+    return putch((char)(c));
+#else
+    return _putch((char)(c));
+#endif
+}
+
+int  sdTerminalIn( void )
+{
+    return _getch();
+}
+
+int  sdQueryTerminal( void )
+{
+    return _kbhit();
+}
+
+int  sdTerminalFlush( void )
+{
+#ifdef PF_NO_FILEIO
+    return -1;
+#else
+    return fflush(PF_STDOUT);
+#endif
+}
+
+void sdTerminalInit( void )
+{
+}
+
+void sdTerminalTerm( void )
+{
+}
+#endif

diff --git a/csrc/win32_console/pf_io_win32_console.c b/csrc/win32_console/pf_io_win32_console.c
index a081812..ced47a8 100644 (file)
--- a/csrc/win32_console/pf_io_win32_console.c
+++ b/csrc/win32_console/pf_io_win32_console.c
@@ -1,231 +1,231 @@
-/* $Id$ */\r
-/***************************************************************\r
-** I/O subsystem for PForth for WIN32 systems.\r
-**\r
-** Use Windows Console so we can add the ANSI console commands needed to support HISTORY\r
-**\r
-** Author: Phil Burk\r
-** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
-**\r
-** The pForth software code is dedicated to the public domain,\r
-** and any third party may reproduce, distribute and modify\r
-** the pForth software code or any derivative works thereof\r
-** without any compensation or license.  The pForth software\r
-** code is provided on an "as is" basis without any warranty\r
-** of any kind, including, without limitation, the implied\r
-** warranties of merchantability and fitness for a particular\r
-** purpose and their equivalents under the laws of any jurisdiction.\r
-**\r
-***************************************************************/\r
-\r
-#include "../pf_all.h"\r
-\r
-#if defined(WIN32) || defined(__NT__)\r
-\r
-#include <windows.h>\r
-\r
-#define ASCII_ESCAPE  (0x1B)\r
-\r
-static HANDLE sConsoleHandle = INVALID_HANDLE_VALUE;\r
-static int sIsConsoleValid = FALSE;\r
-\r
-typedef enum ConsoleState_e\r
-{\r
-       SDCONSOLE_STATE_IDLE = 0,\r
-       SDCONSOLE_STATE_GOT_ESCAPE,\r
-       SDCONSOLE_STATE_GOT_BRACKET\r
-\r
-} ConsoleState;\r
-\r
-static int sConsoleState = SDCONSOLE_STATE_IDLE;\r
-static int sParam1 = 0;\r
-static CONSOLE_SCREEN_BUFFER_INFO sScreenInfo;\r
-\r
-/******************************************************************/\r
-static void sdConsoleEmit( char c )\r
-{\r
-  /* Write a WCHAR in case we have compiled with Unicode support.\r
-   * Otherwise we will see '?' printed.*/\r
-       WCHAR  wc = (WCHAR) c;\r
-       DWORD count;\r
-       if( sIsConsoleValid )\r
-       {\r
-               WriteConsoleW(sConsoleHandle, &wc, 1, &count, NULL );\r
-       }\r
-       else\r
-       {\r
-          /* This will get called if we are redirecting to a file.*/\r
-               WriteFile(sConsoleHandle, &c, 1, &count, NULL );\r
-       }\r
-}\r
-\r
-/******************************************************************/\r
-static void sdClearScreen( void )\r
-{\r
-       if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )\r
-       {\r
-               COORD XY;\r
-               int numNeeded;\r
-               DWORD count;\r
-               XY.X = 0;\r
-               XY.Y = sScreenInfo.srWindow.Top;\r
-               numNeeded = sScreenInfo.dwSize.X * (sScreenInfo.srWindow.Bottom - sScreenInfo.srWindow.Top + 1);\r
-               FillConsoleOutputCharacter(\r
-                       sConsoleHandle, ' ', numNeeded, XY, &count );\r
-               SetConsoleCursorPosition( sConsoleHandle, XY );\r
-       }\r
-}\r
-\r
-/******************************************************************/\r
-static void sdEraseEOL( void )\r
-{\r
-       if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )\r
-       {\r
-               COORD savedXY;\r
-               int numNeeded;\r
-               DWORD count;\r
-               savedXY.X = sScreenInfo.dwCursorPosition.X;\r
-               savedXY.Y = sScreenInfo.dwCursorPosition.Y;\r
-               numNeeded = sScreenInfo.dwSize.X - savedXY.X;\r
-               FillConsoleOutputCharacter(\r
-                       sConsoleHandle, ' ', numNeeded, savedXY, &count );\r
-       }\r
-}\r
-\r
-/******************************************************************/\r
-static void sdCursorBack( int dx )\r
-{\r
-       if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )\r
-       {\r
-               COORD XY;\r
-               XY.X = sScreenInfo.dwCursorPosition.X;\r
-               XY.Y = sScreenInfo.dwCursorPosition.Y;\r
-               XY.X -= dx;\r
-               if( XY.X < 0 ) XY.X = 0;\r
-               SetConsoleCursorPosition( sConsoleHandle, XY );\r
-       }\r
-}\r
-/******************************************************************/\r
-static void sdCursorForward( int dx )\r
-{\r
-       if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )\r
-       {\r
-               COORD XY;\r
-               int width = sScreenInfo.dwSize.X;\r
-               XY.X = sScreenInfo.dwCursorPosition.X;\r
-               XY.Y = sScreenInfo.dwCursorPosition.Y;\r
-               XY.X += dx;\r
-               if( XY.X > width ) XY.X = width;\r
-               SetConsoleCursorPosition( sConsoleHandle, XY );\r
-       }\r
-}\r
-\r
-/******************************************************************/\r
-/* Use console mode I/O so that KEY and ?TERMINAL will work.\r
- * Parse ANSI escape sequences and call the appropriate cursor\r
- * control functions.\r
- */\r
-int  sdTerminalOut( char c )\r
-{\r
-       switch( sConsoleState )\r
-       {\r
-       case SDCONSOLE_STATE_IDLE:\r
-               switch( c )\r
-               {\r
-               case ASCII_ESCAPE:\r
-                       sConsoleState = SDCONSOLE_STATE_GOT_ESCAPE;\r
-                       break;\r
-               default:\r
-                       sdConsoleEmit( c );\r
-               }\r
-               break;\r
-\r
-       case SDCONSOLE_STATE_GOT_ESCAPE:\r
-               switch( c )\r
-               {\r
-               case '[':\r
-                       sConsoleState = SDCONSOLE_STATE_GOT_BRACKET;\r
-                       sParam1 = 0;\r
-                       break;\r
-               default:\r
-                       sConsoleState = SDCONSOLE_STATE_IDLE;\r
-                       sdConsoleEmit( c );\r
-               }\r
-               break;\r
-\r
-       case SDCONSOLE_STATE_GOT_BRACKET:\r
-               if( (c >= '0') && (c <= '9') )\r
-               {\r
-                       sParam1 = (sParam1 * 10) + (c - '0');\r
-               }\r
-               else\r
-               {\r
-                       sConsoleState = SDCONSOLE_STATE_IDLE;\r
-                       if( c == 'K')\r
-                       {\r
-                               sdEraseEOL();\r
-                       }\r
-                       else if( c == 'D' )\r
-                       {\r
-                               sdCursorBack( sParam1 );\r
-                       }\r
-                       else if( c == 'C' )\r
-                       {\r
-                               sdCursorForward( sParam1 );\r
-                       }\r
-                       else if( (c == 'J') && (sParam1 == 2) )\r
-                       {\r
-                               sdClearScreen();\r
-                       }\r
-               }\r
-               break;\r
-       }\r
-       return 0;\r
-}\r
-\r
-/* Needed cuz _getch() does not echo. */\r
-int  sdTerminalEcho( char c )\r
-{\r
-       sdConsoleEmit((char)(c));\r
-       return 0;\r
-}\r
-\r
-int  sdTerminalIn( void )\r
-{\r
-       return _getch();\r
-}\r
-\r
-int  sdQueryTerminal( void )\r
-{\r
-       return _kbhit();\r
-}\r
-\r
-int  sdTerminalFlush( void )\r
-{\r
-#ifdef PF_NO_FILEIO\r
-       return -1;\r
-#else\r
-       return fflush(PF_STDOUT);\r
-#endif\r
-}\r
-\r
-void sdTerminalInit( void )\r
-{\r
-       DWORD mode = 0;\r
-       sConsoleHandle = GetStdHandle( STD_OUTPUT_HANDLE );\r
-       if( GetConsoleMode( sConsoleHandle, &mode ) )\r
-       {\r
-          /*printf("GetConsoleMode() mode is 0x%08X\n", mode );*/\r
-               sIsConsoleValid = TRUE;\r
-       }\r
-       else\r
-       {\r
-          /*printf("GetConsoleMode() failed\n", mode );*/\r
-               sIsConsoleValid = FALSE;\r
-       }\r
-}\r
-\r
-void sdTerminalTerm( void )\r
-{\r
-}\r
-#endif\r
+/* $Id$ */
+/***************************************************************
+** I/O subsystem for PForth for WIN32 systems.
+**
+** Use Windows Console so we can add the ANSI console commands needed to support HISTORY
+**
+** Author: Phil Burk
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+**
+** The pForth software code is dedicated to the public domain,
+** and any third party may reproduce, distribute and modify
+** the pForth software code or any derivative works thereof
+** without any compensation or license.  The pForth software
+** code is provided on an "as is" basis without any 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.
+**
+***************************************************************/
+
+#include "../pf_all.h"
+
+#if defined(WIN32) || defined(__NT__)
+
+#include <windows.h>
+
+#define ASCII_ESCAPE  (0x1B)
+
+static HANDLE sConsoleHandle = INVALID_HANDLE_VALUE;
+static int sIsConsoleValid = FALSE;
+
+typedef enum ConsoleState_e
+{
+    SDCONSOLE_STATE_IDLE = 0,
+    SDCONSOLE_STATE_GOT_ESCAPE,
+    SDCONSOLE_STATE_GOT_BRACKET
+
+} ConsoleState;
+
+static int sConsoleState = SDCONSOLE_STATE_IDLE;
+static int sParam1 = 0;
+static CONSOLE_SCREEN_BUFFER_INFO sScreenInfo;
+
+/******************************************************************/
+static void sdConsoleEmit( char c )
+{
+  /* Write a WCHAR in case we have compiled with Unicode support.
+   * Otherwise we will see '?' printed.*/
+    WCHAR  wc = (WCHAR) c;
+    DWORD count;
+    if( sIsConsoleValid )
+    {
+        WriteConsoleW(sConsoleHandle, &wc, 1, &count, NULL );
+    }
+    else
+    {
+          /* This will get called if we are redirecting to a file.*/
+        WriteFile(sConsoleHandle, &c, 1, &count, NULL );
+    }
+}
+
+/******************************************************************/
+static void sdClearScreen( void )
+{
+    if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )
+    {
+        COORD XY;
+        int numNeeded;
+        DWORD count;
+        XY.X = 0;
+        XY.Y = sScreenInfo.srWindow.Top;
+        numNeeded = sScreenInfo.dwSize.X * (sScreenInfo.srWindow.Bottom - sScreenInfo.srWindow.Top + 1);
+        FillConsoleOutputCharacter(
+            sConsoleHandle, ' ', numNeeded, XY, &count );
+        SetConsoleCursorPosition( sConsoleHandle, XY );
+    }
+}
+
+/******************************************************************/
+static void sdEraseEOL( void )
+{
+    if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )
+    {
+        COORD savedXY;
+        int numNeeded;
+        DWORD count;
+        savedXY.X = sScreenInfo.dwCursorPosition.X;
+        savedXY.Y = sScreenInfo.dwCursorPosition.Y;
+        numNeeded = sScreenInfo.dwSize.X - savedXY.X;
+        FillConsoleOutputCharacter(
+            sConsoleHandle, ' ', numNeeded, savedXY, &count );
+    }
+}
+
+/******************************************************************/
+static void sdCursorBack( int dx )
+{
+    if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )
+    {
+        COORD XY;
+        XY.X = sScreenInfo.dwCursorPosition.X;
+        XY.Y = sScreenInfo.dwCursorPosition.Y;
+        XY.X -= dx;
+        if( XY.X < 0 ) XY.X = 0;
+        SetConsoleCursorPosition( sConsoleHandle, XY );
+    }
+}
+/******************************************************************/
+static void sdCursorForward( int dx )
+{
+    if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) )
+    {
+        COORD XY;
+        int width = sScreenInfo.dwSize.X;
+        XY.X = sScreenInfo.dwCursorPosition.X;
+        XY.Y = sScreenInfo.dwCursorPosition.Y;
+        XY.X += dx;
+        if( XY.X > width ) XY.X = width;
+        SetConsoleCursorPosition( sConsoleHandle, XY );
+    }
+}
+
+/******************************************************************/
+/* Use console mode I/O so that KEY and ?TERMINAL will work.
+ * Parse ANSI escape sequences and call the appropriate cursor
+ * control functions.
+ */
+int  sdTerminalOut( char c )
+{
+    switch( sConsoleState )
+    {
+    case SDCONSOLE_STATE_IDLE:
+        switch( c )
+        {
+        case ASCII_ESCAPE:
+            sConsoleState = SDCONSOLE_STATE_GOT_ESCAPE;
+            break;
+        default:
+            sdConsoleEmit( c );
+        }
+        break;
+
+    case SDCONSOLE_STATE_GOT_ESCAPE:
+        switch( c )
+        {
+        case '[':
+            sConsoleState = SDCONSOLE_STATE_GOT_BRACKET;
+            sParam1 = 0;
+            break;
+        default:
+            sConsoleState = SDCONSOLE_STATE_IDLE;
+            sdConsoleEmit( c );
+        }
+        break;
+
+    case SDCONSOLE_STATE_GOT_BRACKET:
+        if( (c >= '0') && (c <= '9') )
+        {
+            sParam1 = (sParam1 * 10) + (c - '0');
+        }
+        else
+        {
+            sConsoleState = SDCONSOLE_STATE_IDLE;
+            if( c == 'K')
+            {
+                sdEraseEOL();
+            }
+            else if( c == 'D' )
+            {
+                sdCursorBack( sParam1 );
+            }
+            else if( c == 'C' )
+            {
+                sdCursorForward( sParam1 );
+            }
+            else if( (c == 'J') && (sParam1 == 2) )
+            {
+                sdClearScreen();
+            }
+        }
+        break;
+    }
+    return 0;
+}
+
+/* Needed cuz _getch() does not echo. */
+int  sdTerminalEcho( char c )
+{
+    sdConsoleEmit((char)(c));
+    return 0;
+}
+
+int  sdTerminalIn( void )
+{
+    return _getch();
+}
+
+int  sdQueryTerminal( void )
+{
+    return _kbhit();
+}
+
+int  sdTerminalFlush( void )
+{
+#ifdef PF_NO_FILEIO
+    return -1;
+#else
+    return fflush(PF_STDOUT);
+#endif
+}
+
+void sdTerminalInit( void )
+{
+    DWORD mode = 0;
+    sConsoleHandle = GetStdHandle( STD_OUTPUT_HANDLE );
+    if( GetConsoleMode( sConsoleHandle, &mode ) )
+    {
+          /*printf("GetConsoleMode() mode is 0x%08X\n", mode );*/
+        sIsConsoleValid = TRUE;
+    }
+    else
+    {
+          /*printf("GetConsoleMode() failed\n", mode );*/
+        sIsConsoleValid = FALSE;
+    }
+}
+
+void sdTerminalTerm( void )
+{
+}
+#endif

diff --git a/fth/ansilocs.fth b/fth/ansilocs.fth
index 29d9075..33c0c71 100644 (file)
--- a/fth/ansilocs.fth
+++ b/fth/ansilocs.fth
@@ -1,203 +1,203 @@
-\ @(#) ansilocs.fth 98/01/26 1.3\r
-\ local variable support words\r
-\ These support the ANSI standard (LOCAL) and TO words.\r
-\\r
-\ They are built from the following low level primitives written in 'C':\r
-\    (local@) ( i+1 -- n , fetch from ith local variable )\r
-\    (local!) ( n i+1 -- , store to ith local variable )\r
-\    (local.entry) ( num -- , allocate stack frame for num local variables )\r
-\    (local.exit)  ( -- , free local variable stack frame )\r
-\    local-compiler ( -- addr , variable containing CFA of locals compiler )\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 10/27/99 Fixed  : foo { -- } 55 ; was entering local frame but not exiting.\r
-\r
-anew task-ansilocs.fth\r
-\r
-private{\r
-\r
-decimal\r
-16 constant LV_MAX_VARS    \ maximum number of local variables\r
-31 constant LV_MAX_CHARS   \ maximum number of letters in name\r
-\r
-lv_max_vars lv_max_chars $array LV-NAMES\r
-variable LV-#NAMES   \ number of names currently defined\r
-\r
-\ Search name table for match\r
-: LV.MATCH ( $string -- index true | $string false )\r
-    0 swap\r
-    lv-#names @ 0\r
-    ?DO  i lv-names\r
-        over $=\r
-        IF  2drop true i LEAVE\r
-        THEN\r
-    LOOP swap\r
-;\r
-\r
-: LV.COMPILE.FETCH  ( index -- )\r
-       1+  \ adjust for optimised (local@), LocalsPtr points above vars\r
-       CASE\r
-       1 OF compile (1_local@) ENDOF\r
-       2 OF compile (2_local@) ENDOF\r
-       3 OF compile (3_local@) ENDOF\r
-       4 OF compile (4_local@) ENDOF\r
-       5 OF compile (5_local@) ENDOF\r
-       6 OF compile (6_local@) ENDOF\r
-       7 OF compile (7_local@) ENDOF\r
-       8 OF compile (8_local@) ENDOF\r
-       dup [compile] literal compile (local@)\r
-       ENDCASE\r
-;\r
-\r
-: LV.COMPILE.STORE  ( index -- )\r
-       1+  \ adjust for optimised (local!), LocalsPtr points above vars\r
-       CASE\r
-       1 OF compile (1_local!) ENDOF\r
-       2 OF compile (2_local!) ENDOF\r
-       3 OF compile (3_local!) ENDOF\r
-       4 OF compile (4_local!) ENDOF\r
-       5 OF compile (5_local!) ENDOF\r
-       6 OF compile (6_local!) ENDOF\r
-       7 OF compile (7_local!) ENDOF\r
-       8 OF compile (8_local!) ENDOF\r
-       dup [compile] literal compile (local!)\r
-       ENDCASE\r
-;\r
-\r
-: LV.COMPILE.LOCAL  ( $name -- handled? , check for matching locals name )\r
-\ ." LV.COMPILER.LOCAL name = " dup count type cr\r
-       lv.match\r
-       IF ( index )\r
-               lv.compile.fetch\r
-               true\r
-       ELSE\r
-               drop false\r
-       THEN\r
-;\r
-\r
-: LV.CLEANUP ( -- , restore stack frame on exit from colon def )\r
-       lv-#names @\r
-       IF\r
-               compile (local.exit)\r
-       THEN\r
-;\r
-: LV.FINISH ( -- , restore stack frame on exit from colon def )\r
-       lv.cleanup\r
-       lv-#names off\r
-       local-compiler off\r
-;\r
-\r
-: LV.SETUP ( -- )\r
-       0 lv-#names !\r
-;\r
-\r
-: LV.TERM\r
-       ." Locals turned off" cr\r
-       lv-#names off\r
-       local-compiler off\r
-;\r
-\r
-if.forgotten lv.term\r
-\r
-}private\r
-\r
-: (LOCAL)  ( adr len -- , ANSI local primitive )\r
-       dup\r
-       IF\r
-               lv-#names @ lv_max_vars >= abort" Too many local variables!"\r
-               lv-#names @  lv-names place\r
-\ Warn programmer if local variable matches an existing dictionary name.\r
-               lv-#names @  lv-names find nip\r
-               IF\r
-                       ." (LOCAL) - Note: "\r
-                       lv-#names @  lv-names count type\r
-                       ."  redefined as a local variable in "\r
-                       latest id. cr\r
-               THEN\r
-               1 lv-#names +!\r
-       ELSE\r
-\ Last local. Finish building local stack frame.\r
-               2drop\r
-               lv-#names @ dup 0=  \ fixed 10/27/99, Thanks to John Providenza\r
-               IF\r
-                       drop ." (LOCAL) - Warning: no locals defined!" cr\r
-               ELSE\r
-                       [compile] literal   compile (local.entry)\r
-                       ['] lv.compile.local local-compiler !\r
-               THEN\r
-       THEN\r
-;\r
-\r
-\r
-: VALUE\r
-       CREATE ( n <name> )\r
-               ,\r
-               immediate\r
-       DOES>\r
-               state @\r
-               IF\r
-                       [compile] aliteral\r
-                       compile @\r
-               ELSE\r
-                       @\r
-               THEN\r
-;\r
-\r
-: TO  ( val <name> -- )\r
-       bl word\r
-       lv.match\r
-       IF  ( -- index )\r
-               lv.compile.store\r
-       ELSE\r
-               find \r
-               1 = 0= abort" TO or -> before non-local or non-value"\r
-               >body  \ point to data\r
-               state @\r
-               IF  \ compiling  ( -- pfa )\r
-                       [compile] aliteral\r
-                       compile !\r
-               ELSE \ executing  ( -- val pfa )\r
-                       !\r
-               THEN\r
-       THEN\r
-; immediate\r
-\r
-: ->  ( -- )  [compile] to  ; immediate\r
-\r
-: +->  ( val <name> -- )\r
-       bl word\r
-       lv.match\r
-       IF  ( -- index )\r
-               1+  \ adjust for optimised (local!), LocalsPtr points above vars\r
-               [compile] literal compile (local+!)\r
-       ELSE\r
-               find \r
-               1 = 0= abort" +-> before non-local or non-value"\r
-               >body  \ point to data\r
-               state @\r
-               IF  \ compiling  ( -- pfa )\r
-                       [compile] aliteral\r
-                       compile +!\r
-               ELSE \ executing  ( -- val pfa )\r
-                       +!\r
-               THEN\r
-       THEN\r
-; immediate\r
-\r
-: :      lv.setup   : ;\r
-: ;      lv.finish  [compile] ;      ; immediate\r
-: exit   lv.cleanup  compile exit   ; immediate\r
-: does>  lv.finish  [compile] does>  ; immediate\r
-\r
-privatize\r
+\ @(#) ansilocs.fth 98/01/26 1.3
+\ local variable support words
+\ These support the ANSI standard (LOCAL) and TO words.
+\
+\ They are built from the following low level primitives written in 'C':
+\    (local@) ( i+1 -- n , fetch from ith local variable )
+\    (local!) ( n i+1 -- , store to ith local variable )
+\    (local.entry) ( num -- , allocate stack frame for num local variables )
+\    (local.exit)  ( -- , free local variable stack frame )
+\    local-compiler ( -- addr , variable containing CFA of locals compiler )
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ 10/27/99 Fixed  : foo { -- } 55 ; was entering local frame but not exiting.
+
+anew task-ansilocs.fth
+
+private{
+
+decimal
+16 constant LV_MAX_VARS    \ maximum number of local variables
+31 constant LV_MAX_CHARS   \ maximum number of letters in name
+
+lv_max_vars lv_max_chars $array LV-NAMES
+variable LV-#NAMES   \ number of names currently defined
+
+\ Search name table for match
+: LV.MATCH ( $string -- index true | $string false )
+    0 swap
+    lv-#names @ 0
+    ?DO  i lv-names
+        over $=
+        IF  2drop true i LEAVE
+        THEN
+    LOOP swap
+;
+
+: LV.COMPILE.FETCH  ( index -- )
+    1+  \ adjust for optimised (local@), LocalsPtr points above vars
+    CASE
+    1 OF compile (1_local@) ENDOF
+    2 OF compile (2_local@) ENDOF
+    3 OF compile (3_local@) ENDOF
+    4 OF compile (4_local@) ENDOF
+    5 OF compile (5_local@) ENDOF
+    6 OF compile (6_local@) ENDOF
+    7 OF compile (7_local@) ENDOF
+    8 OF compile (8_local@) ENDOF
+    dup [compile] literal compile (local@)
+    ENDCASE
+;
+
+: LV.COMPILE.STORE  ( index -- )
+    1+  \ adjust for optimised (local!), LocalsPtr points above vars
+    CASE
+    1 OF compile (1_local!) ENDOF
+    2 OF compile (2_local!) ENDOF
+    3 OF compile (3_local!) ENDOF
+    4 OF compile (4_local!) ENDOF
+    5 OF compile (5_local!) ENDOF
+    6 OF compile (6_local!) ENDOF
+    7 OF compile (7_local!) ENDOF
+    8 OF compile (8_local!) ENDOF
+    dup [compile] literal compile (local!)
+    ENDCASE
+;
+
+: LV.COMPILE.LOCAL  ( $name -- handled? , check for matching locals name )
+\ ." LV.COMPILER.LOCAL name = " dup count type cr
+    lv.match
+    IF ( index )
+        lv.compile.fetch
+        true
+    ELSE
+        drop false
+    THEN
+;
+
+: LV.CLEANUP ( -- , restore stack frame on exit from colon def )
+    lv-#names @
+    IF
+        compile (local.exit)
+    THEN
+;
+: LV.FINISH ( -- , restore stack frame on exit from colon def )
+    lv.cleanup
+    lv-#names off
+    local-compiler off
+;
+
+: LV.SETUP ( -- )
+    0 lv-#names !
+;
+
+: LV.TERM
+    ." Locals turned off" cr
+    lv-#names off
+    local-compiler off
+;
+
+if.forgotten lv.term
+
+}private
+
+: (LOCAL)  ( adr len -- , ANSI local primitive )
+    dup
+    IF
+        lv-#names @ lv_max_vars >= abort" Too many local variables!"
+        lv-#names @  lv-names place
+\ Warn programmer if local variable matches an existing dictionary name.
+        lv-#names @  lv-names find nip
+        IF
+            ." (LOCAL) - Note: "
+            lv-#names @  lv-names count type
+            ."  redefined as a local variable in "
+            latest id. cr
+        THEN
+        1 lv-#names +!
+    ELSE
+\ Last local. Finish building local stack frame.
+        2drop
+        lv-#names @ dup 0=  \ fixed 10/27/99, Thanks to John Providenza
+        IF
+            drop ." (LOCAL) - Warning: no locals defined!" cr
+        ELSE
+            [compile] literal   compile (local.entry)
+            ['] lv.compile.local local-compiler !
+        THEN
+    THEN
+;
+
+
+: VALUE
+    CREATE ( n <name> )
+        ,
+        immediate
+    DOES>
+        state @
+        IF
+            [compile] aliteral
+            compile @
+        ELSE
+            @
+        THEN
+;
+
+: TO  ( val <name> -- )
+    bl word
+    lv.match
+    IF  ( -- index )
+        lv.compile.store
+    ELSE
+        find
+        1 = 0= abort" TO or -> before non-local or non-value"
+        >body  \ point to data
+        state @
+        IF  \ compiling  ( -- pfa )
+            [compile] aliteral
+            compile !
+        ELSE \ executing  ( -- val pfa )
+            !
+        THEN
+    THEN
+; immediate
+
+: ->  ( -- )  [compile] to  ; immediate
+
+: +->  ( val <name> -- )
+    bl word
+    lv.match
+    IF  ( -- index )
+        1+  \ adjust for optimised (local!), LocalsPtr points above vars
+        [compile] literal compile (local+!)
+    ELSE
+        find
+        1 = 0= abort" +-> before non-local or non-value"
+        >body  \ point to data
+        state @
+        IF  \ compiling  ( -- pfa )
+            [compile] aliteral
+            compile +!
+        ELSE \ executing  ( -- val pfa )
+            +!
+        THEN
+    THEN
+; immediate
+
+: :      lv.setup   : ;
+: ;      lv.finish  [compile] ;      ; immediate
+: exit   lv.cleanup  compile exit   ; immediate
+: does>  lv.finish  [compile] does>  ; immediate
+
+privatize

diff --git a/fth/bench.fth b/fth/bench.fth
index bd5c430..40262ec 100644 (file)
--- a/fth/bench.fth
+++ b/fth/bench.fth
@@ -1,198 +1,198 @@
-\ @(#) bench.fth 97/12/10 1.1\r
-\ Benchmark Forth\r
-\ by Phil Burk\r
-\ 11/17/95\r
-\\r
-\ pForthV9 on Indy, compiled with gcc\r
-\  bench1  took 15 seconds\r
-\  bench2  took 16 seconds\r
-\  bench3  took 17 seconds\r
-\  bench4  took 17 seconds\r
-\  bench5  took 19 seconds\r
-\  sieve   took  4 seconds\r
-\\r
-\ Darren Gibbs reports that on an SGI Octane loaded with multiple users:\r
-\  bench1  took 2.8sec\r
-\  bench2  took 2.7\r
-\  bench3  took 2.9\r
-\  bench4  took 2.1\r
-\  bench 5 took 2.5\r
-\  seive   took .6\r
-\\r
-\ HForth on Mac Quadra 800, 68040\r
-\  bench1  took 1.73 seconds\r
-\  bench2  took 6.48 seconds\r
-\  bench3  took 2.65 seconds\r
-\  bench4  took 2.50 seconds\r
-\  bench5  took 1.91 seconds\r
-\  sieve   took 0.45 seconds\r
-\\r
-\ pForthV9 on Mac Quadra 800\r
-\  bench1  took 40 seconds\r
-\  bench2  took 43 seconds\r
-\  bench3  took 43 seconds\r
-\  bench4  took 44 seconds\r
-\  bench5  took 42 seconds\r
-\  sieve   took 20 seconds\r
-\\r
-\ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook\r
-\  bench1  took 8.6 seconds\r
-\  bench2  took 9.0 seconds\r
-\  bench3  took 9.7 seconds\r
-\  bench4  took 8.8 seconds\r
-\  bench5  took 10.3 seconds\r
-\  sieve   took 2.3 seconds\r
-\\r
-\ HForth on PB5300\r
-\  bench1  took 1.1 seconds\r
-\  bench2  took 3.6 seconds\r
-\  bench3  took 1.7 seconds\r
-\  bench4  took 1.2 seconds\r
-\  bench5  took 1.3 seconds\r
-\  sieve   took 0.2 seconds\r
-\r
-anew task-bench.fth\r
-\r
-decimal\r
-\r
-\ benchmark primitives\r
-create #do 2000000   ,\r
-\r
-: t1           #do @ 0      do                     loop ;\r
-: t2  23 45    #do @ 0      do  swap               loop   2drop ;\r
-: t3  23       #do @ 0      do  dup drop           loop drop ;\r
-: t4  23 45    #do @ 0      do  over drop          loop 2drop ;\r
-: t5           #do @ 0      do  23 45 + drop       loop ;\r
-: t6  23       #do @ 0      do  >r r>              loop drop ;\r
-: t7  23 45 67 #do @ 0      do  rot                loop 2drop drop ;\r
-: t8           #do @ 0      do  23 2* drop         loop  ;\r
-: t9           #do @ 10 / 0 do  23 5 /mod 2drop    loop ;\r
-: t10     #do  #do @ 0      do  dup @ drop         loop drop ;\r
-\r
-: foo ( noop ) ;\r
-: t11          #do @ 0      do  foo                loop ;\r
-\r
-\ more complex benchmarks -----------------------\r
-\r
-\ BENCH1 - sum data ---------------------------------------\r
-create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 ,\r
-: sum.cells ( addr num -- sum )\r
-       0 swap \ sum\r
-       0 DO\r
-               over \ get address\r
-               i cells + @ +\r
-       LOOP\r
-       swap drop\r
-;\r
-\r
-: bench1 ( -- )\r
-       200000 0\r
-       DO\r
-               data1 8 sum.cells drop\r
-       LOOP\r
-;\r
-\r
-\ BENCH2 - recursive factorial --------------------------\r
-: factorial ( n -- n! )\r
-       dup 1 >\r
-       IF\r
-               dup 1- recurse *\r
-       ELSE\r
-               drop 1\r
-       THEN\r
-;\r
-\r
-: bench2 ( -- )\r
-       200000 0\r
-       DO\r
-               10 factorial drop\r
-       LOOP\r
-;\r
-\r
-\ BENCH3 - DEFER ----------------------------------\r
-defer calc.answer\r
-: answer ( n -- m )\r
-       dup +\r
-       $ a5a5 xor\r
-       1000 max\r
-;\r
-' answer is calc.answer\r
-: bench3\r
-       1500000 0\r
-       DO\r
-               i calc.answer drop\r
-       LOOP\r
-;\r
-       \r
-\ BENCH4 - locals ---------------------------------\r
-: use.locals { x1 x2 | aa bb -- result }\r
-       x1 2* -> aa\r
-       x2 2/ -> bb\r
-       x1 aa *\r
-       x2 bb * +\r
-;\r
-\r
-: bench4\r
-       400000 0\r
-       DO\r
-               234 567 use.locals drop\r
-       LOOP\r
-;\r
-\r
-\ BENCH5 - string compare -------------------------------\r
-: match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag }\r
-       $s1 count -> len1 -> adr1\r
-       $s2 count -> len2 -> adr2\r
-       len1 len2 -\r
-       IF\r
-               FALSE\r
-       ELSE\r
-               TRUE\r
-               len1 0\r
-               DO\r
-                       adr1 i + c@\r
-                       adr2 i + c@ -\r
-                       IF\r
-                               drop FALSE\r
-                               leave\r
-                       THEN\r
-               LOOP\r
-       THEN\r
-;\r
-\r
-: bench5 ( -- )\r
-       60000 0\r
-       DO\r
-               " This is a string. X foo"\r
-               " This is a string. Y foo" match.strings drop\r
-       LOOP\r
-;\r
-\r
-\ SIEVE OF ERATOSTHENES from BYTE magazine -----------------------\r
-\r
-DECIMAL 8190 CONSTANT TSIZE\r
-\r
-VARIABLE FLAGS TSIZE ALLOT\r
-\r
-: <SIEVE>  ( --- #primes )  FLAGS TSIZE 1 FILL\r
- 0  TSIZE 0\r
- DO   ( n )  I FLAGS + C@\r
-      IF    I  DUP +  3 +   DUP I +  (  I2*+3 I3*+3 )\r
-           BEGIN  DUP TSIZE <  ( same flag )\r
-           WHILE  0 OVER FLAGS + C! (  i' i'' )   OVER +\r
-           REPEAT 2DROP  1+\r
-      THEN\r
- LOOP       ;\r
-\r
-: SIEVE  ." 10 iterations " CR  0   10 0 \r
-  DO     <SIEVE> swap drop \r
-  LOOP   . ." primes " CR ;\r
-\r
-: SIEVE50  ." 50 iterations " CR  0   50 0 \r
-  DO     <SIEVE> swap drop \r
-  LOOP   . ." primes " CR ;\r
-\r
-\ 10 iterations\r
-\ 21.5 sec  Amiga Multi-Forth  Indirect Threaded\r
-\ 8.82 sec  Amiga 1000 running JForth\r
-\ ~5 sec  SGI Indy running pForthV9\r
+\ @(#) bench.fth 97/12/10 1.1
+\ Benchmark Forth
+\ by Phil Burk
+\ 11/17/95
+\
+\ pForthV9 on Indy, compiled with gcc
+\  bench1  took 15 seconds
+\  bench2  took 16 seconds
+\  bench3  took 17 seconds
+\  bench4  took 17 seconds
+\  bench5  took 19 seconds
+\  sieve   took  4 seconds
+\
+\ Darren Gibbs reports that on an SGI Octane loaded with multiple users:
+\  bench1  took 2.8sec
+\  bench2  took 2.7
+\  bench3  took 2.9
+\  bench4  took 2.1
+\  bench 5 took 2.5
+\  seive   took .6
+\
+\ HForth on Mac Quadra 800, 68040
+\  bench1  took 1.73 seconds
+\  bench2  took 6.48 seconds
+\  bench3  took 2.65 seconds
+\  bench4  took 2.50 seconds
+\  bench5  took 1.91 seconds
+\  sieve   took 0.45 seconds
+\
+\ pForthV9 on Mac Quadra 800
+\  bench1  took 40 seconds
+\  bench2  took 43 seconds
+\  bench3  took 43 seconds
+\  bench4  took 44 seconds
+\  bench5  took 42 seconds
+\  sieve   took 20 seconds
+\
+\ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook
+\  bench1  took 8.6 seconds
+\  bench2  took 9.0 seconds
+\  bench3  took 9.7 seconds
+\  bench4  took 8.8 seconds
+\  bench5  took 10.3 seconds
+\  sieve   took 2.3 seconds
+\
+\ HForth on PB5300
+\  bench1  took 1.1 seconds
+\  bench2  took 3.6 seconds
+\  bench3  took 1.7 seconds
+\  bench4  took 1.2 seconds
+\  bench5  took 1.3 seconds
+\  sieve   took 0.2 seconds
+
+anew task-bench.fth
+
+decimal
+
+\ benchmark primitives
+create #do 2000000   ,
+
+: t1           #do @ 0      do                     loop ;
+: t2  23 45    #do @ 0      do  swap               loop   2drop ;
+: t3  23       #do @ 0      do  dup drop           loop drop ;
+: t4  23 45    #do @ 0      do  over drop          loop 2drop ;
+: t5           #do @ 0      do  23 45 + drop       loop ;
+: t6  23       #do @ 0      do  >r r>              loop drop ;
+: t7  23 45 67 #do @ 0      do  rot                loop 2drop drop ;
+: t8           #do @ 0      do  23 2* drop         loop  ;
+: t9           #do @ 10 / 0 do  23 5 /mod 2drop    loop ;
+: t10     #do  #do @ 0      do  dup @ drop         loop drop ;
+
+: foo ( noop ) ;
+: t11          #do @ 0      do  foo                loop ;
+
+\ more complex benchmarks -----------------------
+
+\ BENCH1 - sum data ---------------------------------------
+create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 ,
+: sum.cells ( addr num -- sum )
+    0 swap \ sum
+    0 DO
+        over \ get address
+        i cells + @ +
+    LOOP
+    swap drop
+;
+
+: bench1 ( -- )
+    200000 0
+    DO
+        data1 8 sum.cells drop
+    LOOP
+;
+
+\ BENCH2 - recursive factorial --------------------------
+: factorial ( n -- n! )
+    dup 1 >
+    IF
+        dup 1- recurse *
+    ELSE
+        drop 1
+    THEN
+;
+
+: bench2 ( -- )
+    200000 0
+    DO
+        10 factorial drop
+    LOOP
+;
+
+\ BENCH3 - DEFER ----------------------------------
+defer calc.answer
+: answer ( n -- m )
+    dup +
+    $ a5a5 xor
+    1000 max
+;
+' answer is calc.answer
+: bench3
+    1500000 0
+    DO
+        i calc.answer drop
+    LOOP
+;
+
+\ BENCH4 - locals ---------------------------------
+: use.locals { x1 x2 | aa bb -- result }
+    x1 2* -> aa
+    x2 2/ -> bb
+    x1 aa *
+    x2 bb * +
+;
+
+: bench4
+    400000 0
+    DO
+        234 567 use.locals drop
+    LOOP
+;
+
+\ BENCH5 - string compare -------------------------------
+: match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag }
+    $s1 count -> len1 -> adr1
+    $s2 count -> len2 -> adr2
+    len1 len2 -
+    IF
+        FALSE
+    ELSE
+        TRUE
+        len1 0
+        DO
+            adr1 i + c@
+            adr2 i + c@ -
+            IF
+                drop FALSE
+                leave
+            THEN
+        LOOP
+    THEN
+;
+
+: bench5 ( -- )
+    60000 0
+    DO
+        " This is a string. X foo"
+        " This is a string. Y foo" match.strings drop
+    LOOP
+;
+
+\ SIEVE OF ERATOSTHENES from BYTE magazine -----------------------
+
+DECIMAL 8190 CONSTANT TSIZE
+
+VARIABLE FLAGS TSIZE ALLOT
+
+: <SIEVE>  ( --- #primes )  FLAGS TSIZE 1 FILL
+ 0  TSIZE 0
+ DO   ( n )  I FLAGS + C@
+      IF    I  DUP +  3 +   DUP I +  (  I2*+3 I3*+3 )
+           BEGIN  DUP TSIZE <  ( same flag )
+           WHILE  0 OVER FLAGS + C! (  i' i'' )   OVER +
+           REPEAT 2DROP  1+
+      THEN
+ LOOP       ;
+
+: SIEVE  ." 10 iterations " CR  0   10 0
+  DO     <SIEVE> swap drop
+  LOOP   . ." primes " CR ;
+
+: SIEVE50  ." 50 iterations " CR  0   50 0
+  DO     <SIEVE> swap drop
+  LOOP   . ." primes " CR ;
+
+\ 10 iterations
+\ 21.5 sec  Amiga Multi-Forth  Indirect Threaded
+\ 8.82 sec  Amiga 1000 running JForth
+\ ~5 sec  SGI Indy running pForthV9

diff --git a/fth/c_struct.fth b/fth/c_struct.fth
index 5898bf8..78cf163 100644 (file)
--- a/fth/c_struct.fth
+++ b/fth/c_struct.fth
@@ -1,242 +1,242 @@
-\ @(#) c_struct.fth 98/01/26 1.2\r
-\ STRUCTUREs are for interfacing with 'C' programs.\r
-\ Structures are created using :STRUCT and ;STRUCT\r
-\\r
-\ This file must be loaded before loading any .J files.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ MOD: PLB 1/16/87 Use abort" instead of er.report\r
-\      MDH 4/14/87 Added sign-extend words to ..@\r
-\ MOD: PLB 9/1/87 Add pointer to last member for debug.\r
-\ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..!\r
-\ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long\r
-\        fixed OB.COMPILE.+@/! for 0 offset\r
-\ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE\r
-\ MOD: RDG 9/19/90 Added floating point member support\r
-\ MOD: PLB 12/21/90 Optimized ..@ and ..!\r
-\ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed\r
-\           Don't need MOVEQ.L  #0,D0 for 16@+WORD and 8@+WORD\r
-\ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR\r
-\ 951112 PLB Added FS@ and FS!\r
-\ This version for the pForth system.\r
-\r
-ANEW TASK-C_STRUCT\r
-\r
-decimal\r
-\ STRUCT ======================================================\r
-: <:STRUCT> ( pfa -- , run time action for a structure)\r
-    [COMPILE] CREATE  \r
-        @ even-up here swap dup ( -- here # # )\r
-        allot  ( make room for ivars )\r
-        0 fill  ( initialize to zero )\r
-\              immediate \ 00001\r
-\      DOES> [compile] aliteral \ 00001\r
-;\r
-\r
-\ Contents of a structure definition.\r
-\    CELL 0 = size of instantiated structures\r
-\    CELL 1 = #bytes to last member name in dictionary.\r
-\             this is relative so it will work with structure\r
-\             relocation schemes like MODULE\r
-\r
-: :STRUCT (  -- , Create a 'C' structure )\r
-\ Check pairs\r
-   ob-state @\r
-   warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"\r
-   ob_def_struct ob-state !     ( set pair flags )\r
-\\r
-\ Create new struct defining word.\r
-  CREATE\r
-      here ob-current-class !  ( set current )\r
-      0 ,        ( initial ivar offset )\r
-      0 ,        ( location for #byte to last )\r
-   DOES>  <:STRUCT>\r
-;\r
-\r
-: ;STRUCT ( -- , terminate structure )\r
-   ob-state @ ob_def_struct = NOT\r
-   abort" ;STRUCT - Missing :STRUCT above!"\r
-   false ob-state !\r
-\r
-\ Point to last member.\r
-   latest ob-current-class @ body> >name -  ( byte difference of NFAs )\r
-   ob-current-class @ cell+ !\r
-\\r
-\ Even up byte offset in case last member was BYTE.\r
-   ob-current-class @ dup @ even-up swap !\r
-;\r
-\r
-\ Member reference words.\r
-: ..   ( object <member> -- member_address , calc addr of member )\r
-    ob.stats? drop state @\r
-    IF   ?dup\r
-         IF   [compile] literal compile +\r
-         THEN\r
-    ELSE +\r
-    THEN\r
-; immediate\r
-\r
-\r
-: (S+C!)  ( val addr offset -- )  + c! ;\r
-: (S+W!)  ( val addr  offset -- )  + w! ;\r
-: (S+!)  ( val addr offset -- )  + ! ;\r
-: (S+REL!)  ( ptr addr offset -- )  + >r if.use->rel r> ! ;\r
-\r
-: compile+!bytes ( offset size -- )\r
-\      ." compile+!bytes ( " over . dup . ." )" cr\r
-       swap [compile] literal   \ compile offset into word\r
-       CASE\r
-       cell OF compile (s+!)  ENDOF\r
-       2 OF compile (s+w!)      ENDOF\r
-       1 OF compile (s+c!)      ENDOF\r
-       -4 OF compile (s+rel!)   ENDOF \ 00002\r
-       -2 OF compile (s+w!)     ENDOF\r
-       -1 OF compile (s+c!)     ENDOF\r
-       true abort" s! - illegal size!"\r
-       ENDCASE\r
-;\r
-\r
-: !BYTES ( value address size -- )\r
-    CASE\r
-    cell OF ! ENDOF\r
-       -4 OF ( aptr addr )  swap if.use->rel swap ! ENDOF \ 00002\r
-       ABS\r
-       2 OF w! ENDOF\r
-       1 OF c! ENDOF\r
-       true abort" s! - illegal size!"\r
-    ENDCASE\r
-;\r
-\r
-\ These provide ways of setting and reading members values\r
-\ without knowing their size in bytes.\r
-: (S!) ( offset size -- , compile proper fetch )\r
-       state @\r
-    IF  compile+!bytes \r
-    ELSE ( -- value addr off size )\r
-        >r + r> !bytes\r
-    THEN\r
-;\r
-: S! ( value object <member> -- , store value in member )\r
-    ob.stats?\r
-       (s!)\r
-; immediate\r
-\r
-: @BYTES ( addr +/-size -- value )\r
-    CASE\r
-    cell OF @  ENDOF\r
-       2 OF w@      ENDOF\r
-       1 OF c@      ENDOF\r
-      -4 OF @ if.rel->use      ENDOF \ 00002\r
-      -2 OF w@ w->s     ENDOF\r
-      -1 OF c@ b->s     ENDOF\r
-       true abort" s@ - illegal size!"\r
-    ENDCASE\r
-;\r
-\r
-: (S+UC@)  ( addr offset -- val )  + c@ ;\r
-: (S+UW@)  ( addr offset -- val )  + w@ ;\r
-: (S+@)  ( addr offset -- val )  + @ ;\r
-: (S+REL@)  ( addr offset -- val )  + @ if.rel->use ;\r
-: (S+C@)  ( addr offset -- val )  + c@ b->s ;\r
-: (S+W@)  ( addr offset -- val )  + w@ w->s ;\r
-\r
-: compile+@bytes ( offset size -- )\r
-\      ." compile+@bytes ( " over . dup . ." )" cr\r
-       swap [compile] literal   \ compile offset into word\r
-       CASE\r
-       cell OF compile (s+@)  ENDOF\r
-       2 OF compile (s+uw@)      ENDOF\r
-       1 OF compile (s+uc@)      ENDOF\r
-       -4 OF compile (s+rel@)      ENDOF \ 00002\r
-       -2 OF compile (s+w@)     ENDOF\r
-       -1 OF compile (s+c@)     ENDOF\r
-       true abort" s@ - illegal size!"\r
-       ENDCASE\r
-;\r
-\r
-: (S@) ( offset size -- , compile proper fetch )\r
-       state @\r
-       IF compile+@bytes\r
-       ELSE >r + r> @bytes\r
-       THEN\r
-;\r
-\r
-: S@ ( object <member> -- value , fetch value from member )\r
-    ob.stats?\r
-       (s@)\r
-; immediate\r
-\r
-\r
-\r
-exists? F* [IF]\r
-\ 951112 Floating Point support\r
-: FLPT  ( <name> -- , declare space for a floating point value. )\r
-     1 floats bytes\r
-;\r
-: (S+F!)  ( val addr offset -- )  + f! ;\r
-: (S+F@)  ( addr offset -- val )  + f@ ;\r
-\r
-: FS! ( value object <member> -- , fetch value from member )\r
-    ob.stats?\r
-    1 floats <> abort" FS@ with non-float!"\r
-       state @\r
-       IF\r
-               [compile] literal\r
-               compile (s+f!)\r
-       ELSE (s+f!)\r
-       THEN\r
-; immediate\r
-: FS@ ( object <member> -- value , fetch value from member )\r
-    ob.stats?\r
-    1 floats <> abort" FS@ with non-float!"\r
-       state @\r
-       IF\r
-               [compile] literal\r
-               compile (s+f@)\r
-       ELSE (s+f@)\r
-       THEN\r
-; immediate\r
-[THEN]\r
-\r
-0 [IF]\r
-:struct mapper\r
-    long map_l1\r
-    long map_l2\r
-    aptr map_a1\r
-    rptr map_r1\r
-    flpt map_f1\r
-    short map_s1\r
-    ushort map_s2\r
-    byte map_b1\r
-    ubyte map_b2\r
-;struct\r
-mapper map1\r
-\r
-: TT\r
-       -500 map1 s! map_s1\r
-       map1 s@ map_s1 -500 - abort" map_s1 failed!"\r
-       -500 map1 s! map_s2\r
-       map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"\r
-       -89 map1 s! map_b1\r
-       map1 s@ map_b1 -89 - abort" map_s1 failed!"\r
-       here map1 s! map_r1\r
-       map1 s@ map_r1 here - abort" map_r1 failed!"\r
-       -89 map1 s! map_b2\r
-       map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"\r
-       23.45 map1 fs! map_f1\r
-       map1 fs@ map_f1 f. ." =?= 23.45" cr\r
-;\r
-." Testing c_struct.fth" cr\r
-TT\r
-[THEN]\r
+\ @(#) c_struct.fth 98/01/26 1.2
+\ STRUCTUREs are for interfacing with 'C' programs.
+\ Structures are created using :STRUCT and ;STRUCT
+\
+\ This file must be loaded before loading any .J files.
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ MOD: PLB 1/16/87 Use abort" instead of er.report
+\      MDH 4/14/87 Added sign-extend words to ..@
+\ MOD: PLB 9/1/87 Add pointer to last member for debug.
+\ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..!
+\ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long
+\        fixed OB.COMPILE.+@/! for 0 offset
+\ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE
+\ MOD: RDG 9/19/90 Added floating point member support
+\ MOD: PLB 12/21/90 Optimized ..@ and ..!
+\ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed
+\           Don't need MOVEQ.L  #0,D0 for 16@+WORD and 8@+WORD
+\ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR
+\ 951112 PLB Added FS@ and FS!
+\ This version for the pForth system.
+
+ANEW TASK-C_STRUCT
+
+decimal
+\ STRUCT ======================================================
+: <:STRUCT> ( pfa -- , run time action for a structure)
+    [COMPILE] CREATE
+        @ even-up here swap dup ( -- here # # )
+        allot  ( make room for ivars )
+        0 fill  ( initialize to zero )
+\       immediate \ 00001
+\   DOES> [compile] aliteral \ 00001
+;
+
+\ Contents of a structure definition.
+\    CELL 0 = size of instantiated structures
+\    CELL 1 = #bytes to last member name in dictionary.
+\             this is relative so it will work with structure
+\             relocation schemes like MODULE
+
+: :STRUCT (  -- , Create a 'C' structure )
+\ Check pairs
+   ob-state @
+   warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"
+   ob_def_struct ob-state !     ( set pair flags )
+\
+\ Create new struct defining word.
+  CREATE
+      here ob-current-class !  ( set current )
+      0 ,        ( initial ivar offset )
+      0 ,        ( location for #byte to last )
+   DOES>  <:STRUCT>
+;
+
+: ;STRUCT ( -- , terminate structure )
+   ob-state @ ob_def_struct = NOT
+   abort" ;STRUCT - Missing :STRUCT above!"
+   false ob-state !
+
+\ Point to last member.
+   latest ob-current-class @ body> >name -  ( byte difference of NFAs )
+   ob-current-class @ cell+ !
+\
+\ Even up byte offset in case last member was BYTE.
+   ob-current-class @ dup @ even-up swap !
+;
+
+\ Member reference words.
+: ..   ( object <member> -- member_address , calc addr of member )
+    ob.stats? drop state @
+    IF   ?dup
+         IF   [compile] literal compile +
+         THEN
+    ELSE +
+    THEN
+; immediate
+
+
+: (S+C!)  ( val addr offset -- )  + c! ;
+: (S+W!)  ( val addr  offset -- )  + w! ;
+: (S+!)  ( val addr offset -- )  + ! ;
+: (S+REL!)  ( ptr addr offset -- )  + >r if.use->rel r> ! ;
+
+: compile+!bytes ( offset size -- )
+\   ." compile+!bytes ( " over . dup . ." )" cr
+    swap [compile] literal   \ compile offset into word
+    CASE
+    cell OF compile (s+!)  ENDOF
+    2 OF compile (s+w!)      ENDOF
+    1 OF compile (s+c!)      ENDOF
+    -4 OF compile (s+rel!)   ENDOF \ 00002
+    -2 OF compile (s+w!)     ENDOF
+    -1 OF compile (s+c!)     ENDOF
+    true abort" s! - illegal size!"
+    ENDCASE
+;
+
+: !BYTES ( value address size -- )
+    CASE
+    cell OF ! ENDOF
+    -4 OF ( aptr addr )  swap if.use->rel swap ! ENDOF \ 00002
+    ABS
+       2 OF w! ENDOF
+       1 OF c! ENDOF
+       true abort" s! - illegal size!"
+    ENDCASE
+;
+
+\ These provide ways of setting and reading members values
+\ without knowing their size in bytes.
+: (S!) ( offset size -- , compile proper fetch )
+    state @
+    IF  compile+!bytes
+    ELSE ( -- value addr off size )
+        >r + r> !bytes
+    THEN
+;
+: S! ( value object <member> -- , store value in member )
+    ob.stats?
+    (s!)
+; immediate
+
+: @BYTES ( addr +/-size -- value )
+    CASE
+    cell OF @  ENDOF
+       2 OF w@      ENDOF
+       1 OF c@      ENDOF
+      -4 OF @ if.rel->use      ENDOF \ 00002
+      -2 OF w@ w->s     ENDOF
+      -1 OF c@ b->s     ENDOF
+       true abort" s@ - illegal size!"
+    ENDCASE
+;
+
+: (S+UC@)  ( addr offset -- val )  + c@ ;
+: (S+UW@)  ( addr offset -- val )  + w@ ;
+: (S+@)  ( addr offset -- val )  + @ ;
+: (S+REL@)  ( addr offset -- val )  + @ if.rel->use ;
+: (S+C@)  ( addr offset -- val )  + c@ b->s ;
+: (S+W@)  ( addr offset -- val )  + w@ w->s ;
+
+: compile+@bytes ( offset size -- )
+\   ." compile+@bytes ( " over . dup . ." )" cr
+    swap [compile] literal   \ compile offset into word
+    CASE
+    cell OF compile (s+@)  ENDOF
+    2 OF compile (s+uw@)      ENDOF
+    1 OF compile (s+uc@)      ENDOF
+    -4 OF compile (s+rel@)      ENDOF \ 00002
+    -2 OF compile (s+w@)     ENDOF
+    -1 OF compile (s+c@)     ENDOF
+    true abort" s@ - illegal size!"
+    ENDCASE
+;
+
+: (S@) ( offset size -- , compile proper fetch )
+    state @
+    IF compile+@bytes
+    ELSE >r + r> @bytes
+    THEN
+;
+
+: S@ ( object <member> -- value , fetch value from member )
+    ob.stats?
+    (s@)
+; immediate
+
+
+
+exists? F* [IF]
+\ 951112 Floating Point support
+: FLPT  ( <name> -- , declare space for a floating point value. )
+     1 floats bytes
+;
+: (S+F!)  ( val addr offset -- )  + f! ;
+: (S+F@)  ( addr offset -- val )  + f@ ;
+
+: FS! ( value object <member> -- , fetch value from member )
+    ob.stats?
+    1 floats <> abort" FS@ with non-float!"
+    state @
+    IF
+        [compile] literal
+        compile (s+f!)
+    ELSE (s+f!)
+    THEN
+; immediate
+: FS@ ( object <member> -- value , fetch value from member )
+    ob.stats?
+    1 floats <> abort" FS@ with non-float!"
+    state @
+    IF
+        [compile] literal
+        compile (s+f@)
+    ELSE (s+f@)
+    THEN
+; immediate
+[THEN]
+
+0 [IF]
+:struct mapper
+    long map_l1
+    long map_l2
+    aptr map_a1
+    rptr map_r1
+    flpt map_f1
+    short map_s1
+    ushort map_s2
+    byte map_b1
+    ubyte map_b2
+;struct
+mapper map1
+
+: TT
+    -500 map1 s! map_s1
+    map1 s@ map_s1 -500 - abort" map_s1 failed!"
+    -500 map1 s! map_s2
+    map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
+    -89 map1 s! map_b1
+    map1 s@ map_b1 -89 - abort" map_s1 failed!"
+    here map1 s! map_r1
+    map1 s@ map_r1 here - abort" map_r1 failed!"
+    -89 map1 s! map_b2
+    map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
+    23.45 map1 fs! map_f1
+    map1 fs@ map_f1 f. ." =?= 23.45" cr
+;
+." Testing c_struct.fth" cr
+TT
+[THEN]

diff --git a/fth/case.fth b/fth/case.fth
index ab71641..830dc83 100644 (file)
--- a/fth/case.fth
+++ b/fth/case.fth
@@ -1,78 +1,78 @@
-\ @(#) case.fth 98/01/26 1.2\r
-\ CASE Statement\r
-\\r
-\ This definition is based upon Wil Baden's assertion that\r
-\ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ MOD: PLB 6/24/91 Check for missing ENDOF\r
-\ MOD: PLB 8/7/91 Add ?OF and RANGEOF\r
-\ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth.\r
-\r
-anew TASK-CASE\r
-\r
-variable CASE-DEPTH\r
-variable OF-DEPTH\r
-\r
-: CASE  ( n -- , start case statement ) ( -c- case-depth )\r
-       ?comp\r
-       of-depth @   0 of-depth !   \ 11/2/99\r
-       case-depth @ 0 case-depth !  ( allow nesting )\r
-; IMMEDIATE\r
-\r
-: ?OF  ( n flag -- | n , doit if true ) ( -c- addr )\r
-       [compile] IF\r
-       compile drop\r
-       1 case-depth +!\r
-       1 of-depth +!\r
-; IMMEDIATE\r
-\r
-: OF  ( n t -- | n , doit if match ) ( -c- addr )\r
-       ?comp\r
-       compile over compile =\r
-       [compile] ?OF\r
-; IMMEDIATE\r
-\r
-: (RANGEOF?)  ( n lo hi -- | n  flag )\r
-       >r over ( n lo n ) <=\r
-       IF\r
-               dup r> ( n n hi ) <=\r
-       ELSE\r
-               rdrop false\r
-       THEN\r
-;\r
-\r
-: RANGEOF  ( n lo hi -- | n , doit if within ) ( -c- addr )\r
-       compile (rangeof?)\r
-       [compile] ?OF\r
-; IMMEDIATE\r
-\r
-: ENDOF  ( -- ) ( addr -c- addr' )\r
-       [compile] ELSE\r
-       -1 of-depth +!\r
-; IMMEDIATE\r
-\r
-: ENDCASE ( n -- )  ( old-case-depth addr' addr' ??? -- )\r
-       of-depth @\r
-       IF >newline ." Missing ENDOF in CASE!" cr abort\r
-       THEN\r
-\\r
-       compile drop\r
-       case-depth @ 0\r
-       ?DO [compile] THEN\r
-       LOOP\r
-       case-depth !\r
-       of-depth !\r
-; IMMEDIATE\r
-\r
+\ @(#) case.fth 98/01/26 1.2
+\ CASE Statement
+\
+\ This definition is based upon Wil Baden's assertion that
+\ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc.
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ MOD: PLB 6/24/91 Check for missing ENDOF
+\ MOD: PLB 8/7/91 Add ?OF and RANGEOF
+\ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth.
+
+anew TASK-CASE
+
+variable CASE-DEPTH
+variable OF-DEPTH
+
+: CASE  ( n -- , start case statement ) ( -c- case-depth )
+    ?comp
+    of-depth @   0 of-depth !   \ 11/2/99
+    case-depth @ 0 case-depth !  ( allow nesting )
+; IMMEDIATE
+
+: ?OF  ( n flag -- | n , doit if true ) ( -c- addr )
+    [compile] IF
+    compile drop
+    1 case-depth +!
+    1 of-depth +!
+; IMMEDIATE
+
+: OF  ( n t -- | n , doit if match ) ( -c- addr )
+    ?comp
+    compile over compile =
+    [compile] ?OF
+; IMMEDIATE
+
+: (RANGEOF?)  ( n lo hi -- | n  flag )
+    >r over ( n lo n ) <=
+    IF
+        dup r> ( n n hi ) <=
+    ELSE
+        rdrop false
+    THEN
+;
+
+: RANGEOF  ( n lo hi -- | n , doit if within ) ( -c- addr )
+    compile (rangeof?)
+    [compile] ?OF
+; IMMEDIATE
+
+: ENDOF  ( -- ) ( addr -c- addr' )
+    [compile] ELSE
+    -1 of-depth +!
+; IMMEDIATE
+
+: ENDCASE ( n -- )  ( old-case-depth addr' addr' ??? -- )
+    of-depth @
+    IF >newline ." Missing ENDOF in CASE!" cr abort
+    THEN
+\
+    compile drop
+    case-depth @ 0
+    ?DO [compile] THEN
+    LOOP
+    case-depth !
+    of-depth !
+; IMMEDIATE
+

diff --git a/fth/condcomp.fth b/fth/condcomp.fth
index d312ca1..dc65c6b 100644 (file)
--- a/fth/condcomp.fth
+++ b/fth/condcomp.fth
@@ -1,50 +1,50 @@
-\ @(#) condcomp.fth 98/01/26 1.2\r
-\ Conditional Compilation support\r
-\\r
-\ Words: STRINGS= [IF] [ELSE] [THEN] EXISTS?\r
-\\r
-\ Lifted from X3J14 dpANS-6 document.\r
-\r
-anew task-condcomp.fth\r
-\r
-: [ELSE]  ( -- )\r
-    1\r
-    BEGIN                                 \ level\r
-      BEGIN\r
-        BL WORD                           \ level $word\r
-        COUNT  DUP                        \ level adr len len\r
-      WHILE                               \ level adr len\r
-        2DUP  S" [IF]"  COMPARE 0=\r
-        IF                                \ level adr len\r
-          2DROP 1+                        \ level'\r
-        ELSE                              \ level adr len\r
-          2DUP  S" [ELSE]"\r
-          COMPARE 0=                      \ level adr len flag\r
-          IF                              \ level adr len\r
-             2DROP 1- DUP IF 1+ THEN      \ level'\r
-          ELSE                            \ level adr len\r
-            S" [THEN]"  COMPARE 0=\r
-            IF\r
-              1-                          \ level'\r
-            THEN\r
-          THEN\r
-        THEN\r
-        ?DUP 0=  IF EXIT THEN             \ level'\r
-      REPEAT  2DROP                       \ level\r
-    REFILL 0= UNTIL                       \ level\r
-    DROP\r
-;  IMMEDIATE\r
-\r
-: [IF]  ( flag -- )\r
-       0=\r
-       IF POSTPONE [ELSE]\r
-       THEN\r
-;  IMMEDIATE\r
-\r
-: [THEN]  ( -- )\r
-;  IMMEDIATE\r
-\r
-: EXISTS? ( <name> -- flag , true if defined )\r
-    bl word find\r
-    swap drop\r
-; immediate\r
+\ @(#) condcomp.fth 98/01/26 1.2
+\ Conditional Compilation support
+\
+\ Words: STRINGS= [IF] [ELSE] [THEN] EXISTS?
+\
+\ Lifted from X3J14 dpANS-6 document.
+
+anew task-condcomp.fth
+
+: [ELSE]  ( -- )
+    1
+    BEGIN                                 \ level
+      BEGIN
+        BL WORD                           \ level $word
+        COUNT  DUP                        \ level adr len len
+      WHILE                               \ level adr len
+        2DUP  S" [IF]"  COMPARE 0=
+        IF                                \ level adr len
+          2DROP 1+                        \ level'
+        ELSE                              \ level adr len
+          2DUP  S" [ELSE]"
+          COMPARE 0=                      \ level adr len flag
+          IF                              \ level adr len
+             2DROP 1- DUP IF 1+ THEN      \ level'
+          ELSE                            \ level adr len
+            S" [THEN]"  COMPARE 0=
+            IF
+              1-                          \ level'
+            THEN
+          THEN
+        THEN
+        ?DUP 0=  IF EXIT THEN             \ level'
+      REPEAT  2DROP                       \ level
+    REFILL 0= UNTIL                       \ level
+    DROP
+;  IMMEDIATE
+
+: [IF]  ( flag -- )
+    0=
+    IF POSTPONE [ELSE]
+    THEN
+;  IMMEDIATE
+
+: [THEN]  ( -- )
+;  IMMEDIATE
+
+: EXISTS? ( <name> -- flag , true if defined )
+    bl word find
+    swap drop
+; immediate

diff --git a/fth/coretest.fth b/fth/coretest.fth
index c91b27c..53fc24d 100644 (file)
--- a/fth/coretest.fth
+++ b/fth/coretest.fth
@@ -1,999 +1,999 @@
-\ From: John Hayes S1I\r
-\ Subject: core.fr\r
-\ Date: Mon, 27 Nov 95 13:10\r
-\r
-\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY\r
-\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.\r
-\ VERSION 1.2\r
-\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.\r
-\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE\r
-\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND\r
-\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.\r
-\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...\r
-\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...\r
-\r
-\ Load test tools - Phil Burk\r
-include? testing tester.fth\r
-\r
-TESTING CORE WORDS\r
-HEX\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING BASIC ASSUMPTIONS\r
-\r
-{ -> }                                 \ START WITH CLEAN SLATE\r
-( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )\r
-{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }\r
-{  0 BITSSET? -> 0 }           ( ZERO IS ALL BITS CLEAR )\r
-{  1 BITSSET? -> 0 0 }         ( OTHER NUMBER HAVE AT LEAST ONE BIT )\r
-{ -1 BITSSET? -> 0 0 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING BOOLEANS: INVERT AND OR XOR\r
-\r
-{ 0 0 AND -> 0 }\r
-{ 0 1 AND -> 0 }\r
-{ 1 0 AND -> 0 }\r
-{ 1 1 AND -> 1 }\r
-\r
-{ 0 INVERT 1 AND -> 1 }\r
-{ 1 INVERT 1 AND -> 0 }\r
-\r
-0       CONSTANT 0S\r
-0 INVERT CONSTANT 1S\r
-\r
-{ 0S INVERT -> 1S }\r
-{ 1S INVERT -> 0S }\r
-\r
-{ 0S 0S AND -> 0S }\r
-{ 0S 1S AND -> 0S }\r
-{ 1S 0S AND -> 0S }\r
-{ 1S 1S AND -> 1S }\r
-\r
-{ 0S 0S OR -> 0S }\r
-{ 0S 1S OR -> 1S }\r
-{ 1S 0S OR -> 1S }\r
-{ 1S 1S OR -> 1S }\r
-\r
-{ 0S 0S XOR -> 0S }\r
-{ 0S 1S XOR -> 1S }\r
-{ 1S 0S XOR -> 1S }\r
-{ 1S 1S XOR -> 0S }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING 2* 2/ LSHIFT RSHIFT\r
-\r
-( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )\r
-1S 1 RSHIFT INVERT CONSTANT MSB\r
-{ MSB BITSSET? -> 0 0 }\r
-\r
-{ 0S 2* -> 0S }\r
-{ 1 2* -> 2 }\r
-{ 4000 2* -> 8000 }\r
-{ 1S 2* 1 XOR -> 1S }\r
-{ MSB 2* -> 0S }\r
-\r
-{ 0S 2/ -> 0S }\r
-{ 1 2/ -> 0 }\r
-{ 4000 2/ -> 2000 }\r
-{ 1S 2/ -> 1S }                                \ MSB PROPOGATED\r
-{ 1S 1 XOR 2/ -> 1S }\r
-{ MSB 2/ MSB AND -> MSB }\r
-\r
-{ 1 0 LSHIFT -> 1 }\r
-{ 1 1 LSHIFT -> 2 }\r
-{ 1 2 LSHIFT -> 4 }\r
-{ 1 F LSHIFT -> 8000 }                 \ BIGGEST GUARANTEED SHIFT\r
-{ 1S 1 LSHIFT 1 XOR -> 1S }\r
-{ MSB 1 LSHIFT -> 0 }\r
-\r
-{ 1 0 RSHIFT -> 1 }\r
-{ 1 1 RSHIFT -> 0 }\r
-{ 2 1 RSHIFT -> 1 }\r
-{ 4 2 RSHIFT -> 1 }\r
-{ 8000 F RSHIFT -> 1 }                 \ BIGGEST\r
-{ MSB 1 RSHIFT MSB AND -> 0 }          \ RSHIFT ZERO FILLS MSBS\r
-{ MSB 1 RSHIFT 2* -> MSB }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING COMPARISONS: 0= = 0< < > U< MIN MAX\r
-0 INVERT                       CONSTANT MAX-UINT\r
-0 INVERT 1 RSHIFT              CONSTANT MAX-INT\r
-0 INVERT 1 RSHIFT INVERT       CONSTANT MIN-INT\r
-0 INVERT 1 RSHIFT              CONSTANT MID-UINT\r
-0 INVERT 1 RSHIFT INVERT       CONSTANT MID-UINT+1\r
-\r
-0S CONSTANT <FALSE>\r
-1S CONSTANT <TRUE>\r
-\r
-{ 0 0= -> <TRUE> }\r
-{ 1 0= -> <FALSE> }\r
-{ 2 0= -> <FALSE> }\r
-{ -1 0= -> <FALSE> }\r
-{ MAX-UINT 0= -> <FALSE> }\r
-{ MIN-INT 0= -> <FALSE> }\r
-{ MAX-INT 0= -> <FALSE> }\r
-\r
-{ 0 0 = -> <TRUE> }\r
-{ 1 1 = -> <TRUE> }\r
-{ -1 -1 = -> <TRUE> }\r
-{ 1 0 = -> <FALSE> }\r
-{ -1 0 = -> <FALSE> }\r
-{ 0 1 = -> <FALSE> }\r
-{ 0 -1 = -> <FALSE> }\r
-\r
-{ 0 0< -> <FALSE> }\r
-{ -1 0< -> <TRUE> }\r
-{ MIN-INT 0< -> <TRUE> }\r
-{ 1 0< -> <FALSE> }\r
-{ MAX-INT 0< -> <FALSE> }\r
-\r
-{ 0 1 < -> <TRUE> }\r
-{ 1 2 < -> <TRUE> }\r
-{ -1 0 < -> <TRUE> }\r
-{ -1 1 < -> <TRUE> }\r
-{ MIN-INT 0 < -> <TRUE> }\r
-{ MIN-INT MAX-INT < -> <TRUE> }\r
-{ 0 MAX-INT < -> <TRUE> }\r
-{ 0 0 < -> <FALSE> }\r
-{ 1 1 < -> <FALSE> }\r
-{ 1 0 < -> <FALSE> }\r
-{ 2 1 < -> <FALSE> }\r
-{ 0 -1 < -> <FALSE> }\r
-{ 1 -1 < -> <FALSE> }\r
-{ 0 MIN-INT < -> <FALSE> }\r
-{ MAX-INT MIN-INT < -> <FALSE> }\r
-{ MAX-INT 0 < -> <FALSE> }\r
-\r
-{ 0 1 > -> <FALSE> }\r
-{ 1 2 > -> <FALSE> }\r
-{ -1 0 > -> <FALSE> }\r
-{ -1 1 > -> <FALSE> }\r
-{ MIN-INT 0 > -> <FALSE> }\r
-{ MIN-INT MAX-INT > -> <FALSE> }\r
-{ 0 MAX-INT > -> <FALSE> }\r
-{ 0 0 > -> <FALSE> }\r
-{ 1 1 > -> <FALSE> }\r
-{ 1 0 > -> <TRUE> }\r
-{ 2 1 > -> <TRUE> }\r
-{ 0 -1 > -> <TRUE> }\r
-{ 1 -1 > -> <TRUE> }\r
-{ 0 MIN-INT > -> <TRUE> }\r
-{ MAX-INT MIN-INT > -> <TRUE> }\r
-{ MAX-INT 0 > -> <TRUE> }\r
-\r
-{ 0 1 U< -> <TRUE> }\r
-{ 1 2 U< -> <TRUE> }\r
-{ 0 MID-UINT U< -> <TRUE> }\r
-{ 0 MAX-UINT U< -> <TRUE> }\r
-{ MID-UINT MAX-UINT U< -> <TRUE> }\r
-{ 0 0 U< -> <FALSE> }\r
-{ 1 1 U< -> <FALSE> }\r
-{ 1 0 U< -> <FALSE> }\r
-{ 2 1 U< -> <FALSE> }\r
-{ MID-UINT 0 U< -> <FALSE> }\r
-{ MAX-UINT 0 U< -> <FALSE> }\r
-{ MAX-UINT MID-UINT U< -> <FALSE> }\r
-\r
-{ 0 1 MIN -> 0 }\r
-{ 1 2 MIN -> 1 }\r
-{ -1 0 MIN -> -1 }\r
-{ -1 1 MIN -> -1 }\r
-{ MIN-INT 0 MIN -> MIN-INT }\r
-{ MIN-INT MAX-INT MIN -> MIN-INT }\r
-{ 0 MAX-INT MIN -> 0 }\r
-{ 0 0 MIN -> 0 }\r
-{ 1 1 MIN -> 1 }\r
-{ 1 0 MIN -> 0 }\r
-{ 2 1 MIN -> 1 }\r
-{ 0 -1 MIN -> -1 }\r
-{ 1 -1 MIN -> -1 }\r
-{ 0 MIN-INT MIN -> MIN-INT }\r
-{ MAX-INT MIN-INT MIN -> MIN-INT }\r
-{ MAX-INT 0 MIN -> 0 }\r
-\r
-{ 0 1 MAX -> 1 }\r
-{ 1 2 MAX -> 2 }\r
-{ -1 0 MAX -> 0 }\r
-{ -1 1 MAX -> 1 }\r
-{ MIN-INT 0 MAX -> 0 }\r
-{ MIN-INT MAX-INT MAX -> MAX-INT }\r
-{ 0 MAX-INT MAX -> MAX-INT }\r
-{ 0 0 MAX -> 0 }\r
-{ 1 1 MAX -> 1 }\r
-{ 1 0 MAX -> 1 }\r
-{ 2 1 MAX -> 2 }\r
-{ 0 -1 MAX -> 0 }\r
-{ 1 -1 MAX -> 1 }\r
-{ 0 MIN-INT MAX -> 0 }\r
-{ MAX-INT MIN-INT MAX -> MAX-INT }\r
-{ MAX-INT 0 MAX -> MAX-INT }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP\r
-\r
-{ 1 2 2DROP -> }\r
-{ 1 2 2DUP -> 1 2 1 2 }\r
-{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }\r
-{ 1 2 3 4 2SWAP -> 3 4 1 2 }\r
-{ 0 ?DUP -> 0 }\r
-{ 1 ?DUP -> 1 1 }\r
-{ -1 ?DUP -> -1 -1 }\r
-{ DEPTH -> 0 }\r
-{ 0 DEPTH -> 0 1 }\r
-{ 0 1 DEPTH -> 0 1 2 }\r
-{ 0 DROP -> }\r
-{ 1 2 DROP -> 1 }\r
-{ 1 DUP -> 1 1 }\r
-{ 1 2 OVER -> 1 2 1 }\r
-{ 1 2 3 ROT -> 2 3 1 }\r
-{ 1 2 SWAP -> 2 1 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING >R R> R@\r
-\r
-{ : GR1 >R R> ; -> }\r
-{ : GR2 >R R@ R> DROP ; -> }\r
-{ 123 GR1 -> 123 }\r
-{ 123 GR2 -> 123 }\r
-{ 1S GR1 -> 1S }   ( RETURN STACK HOLDS CELLS )\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE\r
-\r
-{ 0 5 + -> 5 }\r
-{ 5 0 + -> 5 }\r
-{ 0 -5 + -> -5 }\r
-{ -5 0 + -> -5 }\r
-{ 1 2 + -> 3 }\r
-{ 1 -2 + -> -1 }\r
-{ -1 2 + -> 1 }\r
-{ -1 -2 + -> -3 }\r
-{ -1 1 + -> 0 }\r
-{ MID-UINT 1 + -> MID-UINT+1 }\r
-\r
-{ 0 5 - -> -5 }\r
-{ 5 0 - -> 5 }\r
-{ 0 -5 - -> 5 }\r
-{ -5 0 - -> -5 }\r
-{ 1 2 - -> -1 }\r
-{ 1 -2 - -> 3 }\r
-{ -1 2 - -> -3 }\r
-{ -1 -2 - -> 1 }\r
-{ 0 1 - -> -1 }\r
-{ MID-UINT+1 1 - -> MID-UINT }\r
-\r
-{ 0 1+ -> 1 }\r
-{ -1 1+ -> 0 }\r
-{ 1 1+ -> 2 }\r
-{ MID-UINT 1+ -> MID-UINT+1 }\r
-\r
-{ 2 1- -> 1 }\r
-{ 1 1- -> 0 }\r
-{ 0 1- -> -1 }\r
-{ MID-UINT+1 1- -> MID-UINT }\r
-\r
-{ 0 NEGATE -> 0 }\r
-{ 1 NEGATE -> -1 }\r
-{ -1 NEGATE -> 1 }\r
-{ 2 NEGATE -> -2 }\r
-{ -2 NEGATE -> 2 }\r
-\r
-{ 0 ABS -> 0 }\r
-{ 1 ABS -> 1 }\r
-{ -1 ABS -> 1 }\r
-{ MIN-INT ABS -> MID-UINT+1 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING MULTIPLY: S>D * M* UM*\r
-\r
-{ 0 S>D -> 0 0 }\r
-{ 1 S>D -> 1 0 }\r
-{ 2 S>D -> 2 0 }\r
-{ -1 S>D -> -1 -1 }\r
-{ -2 S>D -> -2 -1 }\r
-{ MIN-INT S>D -> MIN-INT -1 }\r
-{ MAX-INT S>D -> MAX-INT 0 }\r
-\r
-{ 0 0 M* -> 0 S>D }\r
-{ 0 1 M* -> 0 S>D }\r
-{ 1 0 M* -> 0 S>D }\r
-{ 1 2 M* -> 2 S>D }\r
-{ 2 1 M* -> 2 S>D }\r
-{ 3 3 M* -> 9 S>D }\r
-{ -3 3 M* -> -9 S>D }\r
-{ 3 -3 M* -> -9 S>D }\r
-{ -3 -3 M* -> 9 S>D }\r
-{ 0 MIN-INT M* -> 0 S>D }\r
-{ 1 MIN-INT M* -> MIN-INT S>D }\r
-{ 2 MIN-INT M* -> 0 1S }\r
-{ 0 MAX-INT M* -> 0 S>D }\r
-{ 1 MAX-INT M* -> MAX-INT S>D }\r
-{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }\r
-{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }\r
-{ MAX-INT MIN-INT M* -> MSB MSB 2/ }\r
-{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }\r
-\r
-{ 0 0 * -> 0 }                         \ TEST IDENTITIES\r
-{ 0 1 * -> 0 }\r
-{ 1 0 * -> 0 }\r
-{ 1 2 * -> 2 }\r
-{ 2 1 * -> 2 }\r
-{ 3 3 * -> 9 }\r
-{ -3 3 * -> -9 }\r
-{ 3 -3 * -> -9 }\r
-{ -3 -3 * -> 9 }\r
-\r
-{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }\r
-{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }\r
-{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }\r
-\r
-{ 0 0 UM* -> 0 0 }\r
-{ 0 1 UM* -> 0 0 }\r
-{ 1 0 UM* -> 0 0 }\r
-{ 1 2 UM* -> 2 0 }\r
-{ 2 1 UM* -> 2 0 }\r
-{ 3 3 UM* -> 9 0 }\r
-\r
-{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }\r
-{ MID-UINT+1 2 UM* -> 0 1 }\r
-{ MID-UINT+1 4 UM* -> 0 2 }\r
-{ 1S 2 UM* -> 1S 1 LSHIFT 1 }\r
-{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD\r
-\r
-{ 0 S>D 1 FM/MOD -> 0 0 }\r
-{ 1 S>D 1 FM/MOD -> 0 1 }\r
-{ 2 S>D 1 FM/MOD -> 0 2 }\r
-{ -1 S>D 1 FM/MOD -> 0 -1 }\r
-{ -2 S>D 1 FM/MOD -> 0 -2 }\r
-{ 0 S>D -1 FM/MOD -> 0 0 }\r
-{ 1 S>D -1 FM/MOD -> 0 -1 }\r
-{ 2 S>D -1 FM/MOD -> 0 -2 }\r
-{ -1 S>D -1 FM/MOD -> 0 1 }\r
-{ -2 S>D -1 FM/MOD -> 0 2 }\r
-{ 2 S>D 2 FM/MOD -> 0 1 }\r
-{ -1 S>D -1 FM/MOD -> 0 1 }\r
-{ -2 S>D -2 FM/MOD -> 0 1 }\r
-{  7 S>D  3 FM/MOD -> 1 2 }\r
-{  7 S>D -3 FM/MOD -> -2 -3 }\r
-{ -7 S>D  3 FM/MOD -> 2 -3 }\r
-{ -7 S>D -3 FM/MOD -> -1 2 }\r
-{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }\r
-{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }\r
-{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }\r
-{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }\r
-{ 1S 1 4 FM/MOD -> 3 MAX-INT }\r
-{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }\r
-{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }\r
-{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }\r
-{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }\r
-{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }\r
-{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }\r
-{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }\r
-{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }\r
-{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }\r
-{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }\r
-{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }\r
-{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }\r
-\r
-{ 0 S>D 1 SM/REM -> 0 0 }\r
-{ 1 S>D 1 SM/REM -> 0 1 }\r
-{ 2 S>D 1 SM/REM -> 0 2 }\r
-{ -1 S>D 1 SM/REM -> 0 -1 }\r
-{ -2 S>D 1 SM/REM -> 0 -2 }\r
-{ 0 S>D -1 SM/REM -> 0 0 }\r
-{ 1 S>D -1 SM/REM -> 0 -1 }\r
-{ 2 S>D -1 SM/REM -> 0 -2 }\r
-{ -1 S>D -1 SM/REM -> 0 1 }\r
-{ -2 S>D -1 SM/REM -> 0 2 }\r
-{ 2 S>D 2 SM/REM -> 0 1 }\r
-{ -1 S>D -1 SM/REM -> 0 1 }\r
-{ -2 S>D -2 SM/REM -> 0 1 }\r
-{  7 S>D  3 SM/REM -> 1 2 }\r
-{  7 S>D -3 SM/REM -> 1 -2 }\r
-{ -7 S>D  3 SM/REM -> -1 -2 }\r
-{ -7 S>D -3 SM/REM -> -1 2 }\r
-{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }\r
-{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }\r
-{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }\r
-{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }\r
-{ 1S 1 4 SM/REM -> 3 MAX-INT }\r
-{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }\r
-{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }\r
-{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }\r
-{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }\r
-{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }\r
-{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }\r
-{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }\r
-{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }\r
-\r
-{ 0 0 1 UM/MOD -> 0 0 }\r
-{ 1 0 1 UM/MOD -> 0 1 }\r
-{ 1 0 2 UM/MOD -> 1 0 }\r
-{ 3 0 2 UM/MOD -> 1 1 }\r
-{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }\r
-{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }\r
-{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }\r
-\r
-: IFFLOORED\r
-   [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;\r
-: IFSYM\r
-   [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;\r
-\r
-\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.\r
-\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.\r
-IFFLOORED : T/MOD  >R S>D R> FM/MOD ;\r
-IFFLOORED : T/     T/MOD SWAP DROP ;\r
-IFFLOORED : TMOD   T/MOD DROP ;\r
-IFFLOORED : T*/MOD >R M* R> FM/MOD ;\r
-IFFLOORED : T*/    T*/MOD SWAP DROP ;\r
-IFSYM     : T/MOD  >R S>D R> SM/REM ;\r
-IFSYM     : T/     T/MOD SWAP DROP ;\r
-IFSYM     : TMOD   T/MOD DROP ;\r
-IFSYM     : T*/MOD >R M* R> SM/REM ;\r
-IFSYM     : T*/    T*/MOD SWAP DROP ;\r
-\r
-{ 0 1 /MOD -> 0 1 T/MOD }\r
-{ 1 1 /MOD -> 1 1 T/MOD }\r
-{ 2 1 /MOD -> 2 1 T/MOD }\r
-{ -1 1 /MOD -> -1 1 T/MOD }\r
-{ -2 1 /MOD -> -2 1 T/MOD }\r
-{ 0 -1 /MOD -> 0 -1 T/MOD }\r
-{ 1 -1 /MOD -> 1 -1 T/MOD }\r
-{ 2 -1 /MOD -> 2 -1 T/MOD }\r
-{ -1 -1 /MOD -> -1 -1 T/MOD }\r
-{ -2 -1 /MOD -> -2 -1 T/MOD }\r
-{ 2 2 /MOD -> 2 2 T/MOD }\r
-{ -1 -1 /MOD -> -1 -1 T/MOD }\r
-{ -2 -2 /MOD -> -2 -2 T/MOD }\r
-{ 7 3 /MOD -> 7 3 T/MOD }\r
-{ 7 -3 /MOD -> 7 -3 T/MOD }\r
-{ -7 3 /MOD -> -7 3 T/MOD }\r
-{ -7 -3 /MOD -> -7 -3 T/MOD }\r
-{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }\r
-{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }\r
-{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }\r
-{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }\r
-\r
-{ 0 1 / -> 0 1 T/ }\r
-{ 1 1 / -> 1 1 T/ }\r
-{ 2 1 / -> 2 1 T/ }\r
-{ -1 1 / -> -1 1 T/ }\r
-{ -2 1 / -> -2 1 T/ }\r
-{ 0 -1 / -> 0 -1 T/ }\r
-{ 1 -1 / -> 1 -1 T/ }\r
-{ 2 -1 / -> 2 -1 T/ }\r
-{ -1 -1 / -> -1 -1 T/ }\r
-{ -2 -1 / -> -2 -1 T/ }\r
-{ 2 2 / -> 2 2 T/ }\r
-{ -1 -1 / -> -1 -1 T/ }\r
-{ -2 -2 / -> -2 -2 T/ }\r
-{ 7 3 / -> 7 3 T/ }\r
-{ 7 -3 / -> 7 -3 T/ }\r
-{ -7 3 / -> -7 3 T/ }\r
-{ -7 -3 / -> -7 -3 T/ }\r
-{ MAX-INT 1 / -> MAX-INT 1 T/ }\r
-{ MIN-INT 1 / -> MIN-INT 1 T/ }\r
-{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }\r
-{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }\r
-\r
-{ 0 1 MOD -> 0 1 TMOD }\r
-{ 1 1 MOD -> 1 1 TMOD }\r
-{ 2 1 MOD -> 2 1 TMOD }\r
-{ -1 1 MOD -> -1 1 TMOD }\r
-{ -2 1 MOD -> -2 1 TMOD }\r
-{ 0 -1 MOD -> 0 -1 TMOD }\r
-{ 1 -1 MOD -> 1 -1 TMOD }\r
-{ 2 -1 MOD -> 2 -1 TMOD }\r
-{ -1 -1 MOD -> -1 -1 TMOD }\r
-{ -2 -1 MOD -> -2 -1 TMOD }\r
-{ 2 2 MOD -> 2 2 TMOD }\r
-{ -1 -1 MOD -> -1 -1 TMOD }\r
-{ -2 -2 MOD -> -2 -2 TMOD }\r
-{ 7 3 MOD -> 7 3 TMOD }\r
-{ 7 -3 MOD -> 7 -3 TMOD }\r
-{ -7 3 MOD -> -7 3 TMOD }\r
-{ -7 -3 MOD -> -7 -3 TMOD }\r
-{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }\r
-{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }\r
-{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }\r
-{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }\r
-\r
-{ 0 2 1 */ -> 0 2 1 T*/ }\r
-{ 1 2 1 */ -> 1 2 1 T*/ }\r
-{ 2 2 1 */ -> 2 2 1 T*/ }\r
-{ -1 2 1 */ -> -1 2 1 T*/ }\r
-{ -2 2 1 */ -> -2 2 1 T*/ }\r
-{ 0 2 -1 */ -> 0 2 -1 T*/ }\r
-{ 1 2 -1 */ -> 1 2 -1 T*/ }\r
-{ 2 2 -1 */ -> 2 2 -1 T*/ }\r
-{ -1 2 -1 */ -> -1 2 -1 T*/ }\r
-{ -2 2 -1 */ -> -2 2 -1 T*/ }\r
-{ 2 2 2 */ -> 2 2 2 T*/ }\r
-{ -1 2 -1 */ -> -1 2 -1 T*/ }\r
-{ -2 2 -2 */ -> -2 2 -2 T*/ }\r
-{ 7 2 3 */ -> 7 2 3 T*/ }\r
-{ 7 2 -3 */ -> 7 2 -3 T*/ }\r
-{ -7 2 3 */ -> -7 2 3 T*/ }\r
-{ -7 2 -3 */ -> -7 2 -3 T*/ }\r
-{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }\r
-{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }\r
-\r
-{ 0 2 1 */MOD -> 0 2 1 T*/MOD }\r
-{ 1 2 1 */MOD -> 1 2 1 T*/MOD }\r
-{ 2 2 1 */MOD -> 2 2 1 T*/MOD }\r
-{ -1 2 1 */MOD -> -1 2 1 T*/MOD }\r
-{ -2 2 1 */MOD -> -2 2 1 T*/MOD }\r
-{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }\r
-{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }\r
-{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }\r
-{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }\r
-{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }\r
-{ 2 2 2 */MOD -> 2 2 2 T*/MOD }\r
-{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }\r
-{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }\r
-{ 7 2 3 */MOD -> 7 2 3 T*/MOD }\r
-{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }\r
-{ -7 2 3 */MOD -> -7 2 3 T*/MOD }\r
-{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }\r
-{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }\r
-{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT\r
-\r
-HERE 1 ALLOT\r
-HERE\r
-CONSTANT 2NDA\r
-CONSTANT 1STA\r
-{ 1STA 2NDA U< -> <TRUE> }             \ HERE MUST GROW WITH ALLOT\r
-{ 1STA 1+ -> 2NDA }                    \ ... BY ONE ADDRESS UNIT\r
-( MISSING TEST: NEGATIVE ALLOT )\r
-\r
-HERE 1 ,\r
-HERE 2 ,\r
-CONSTANT 2ND\r
-CONSTANT 1ST\r
-{ 1ST 2ND U< -> <TRUE> }                       \ HERE MUST GROW WITH ALLOT\r
-{ 1ST CELL+ -> 2ND }                   \ ... BY ONE CELL\r
-{ 1ST 1 CELLS + -> 2ND }\r
-{ 1ST @ 2ND @ -> 1 2 }\r
-{ 5 1ST ! -> }\r
-{ 1ST @ 2ND @ -> 5 2 }\r
-{ 6 2ND ! -> }\r
-{ 1ST @ 2ND @ -> 5 6 }\r
-{ 1ST 2@ -> 6 5 }\r
-{ 2 1 1ST 2! -> }\r
-{ 1ST 2@ -> 2 1 }\r
-{ 1S 1ST !  1ST @ -> 1S }              \ CAN STORE CELL-WIDE VALUE\r
-\r
-HERE 1 C,\r
-HERE 2 C,\r
-CONSTANT 2NDC\r
-CONSTANT 1STC\r
-{ 1STC 2NDC U< -> <TRUE> }             \ HERE MUST GROW WITH ALLOT\r
-{ 1STC CHAR+ -> 2NDC }                 \ ... BY ONE CHAR\r
-{ 1STC 1 CHARS + -> 2NDC }\r
-{ 1STC C@ 2NDC C@ -> 1 2 }\r
-{ 3 1STC C! -> }\r
-{ 1STC C@ 2NDC C@ -> 3 2 }\r
-{ 4 2NDC C! -> }\r
-{ 1STC C@ 2NDC C@ -> 3 4 }\r
-\r
-ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT\r
-CONSTANT A-ADDR  CONSTANT UA-ADDR\r
-{ UA-ADDR ALIGNED -> A-ADDR }\r
-{    1 A-ADDR C!  A-ADDR C@ ->    1 }\r
-{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }\r
-{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }\r
-{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }\r
-{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }\r
-{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }\r
-{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }\r
-\r
-: BITS ( X -- U )\r
-   0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;\r
-( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )\r
-{ 1 CHARS 1 < -> <FALSE> }\r
-{ 1 CHARS 1 CELLS > -> <FALSE> }\r
-( TBD: HOW TO FIND NUMBER OF BITS? )\r
-\r
-( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )\r
-{ 1 CELLS 1 < -> <FALSE> }\r
-{ 1 CELLS 1 CHARS MOD -> 0 }\r
-{ 1S BITS 10 < -> <FALSE> }\r
-\r
-{ 0 1ST ! -> }\r
-{ 1 1ST +! -> }\r
-{ 1ST @ -> 1 }\r
-{ -1 1ST +! 1ST @ -> 0 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING CHAR [CHAR] [ ] BL S"\r
-\r
-{ BL -> 20 }\r
-{ CHAR X -> 58 }\r
-{ CHAR HELLO -> 48 }\r
-{ : GC1 [CHAR] X ; -> }\r
-{ : GC2 [CHAR] HELLO ; -> }\r
-{ GC1 -> 58 }\r
-{ GC2 -> 48 }\r
-{ : GC3 [ GC1 ] LITERAL ; -> }\r
-{ GC3 -> 58 }\r
-{ : GC4 S" XY" ; -> }\r
-{ GC4 SWAP DROP -> 2 }\r
-{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE\r
-\r
-{ : GT1 123 ; -> }\r
-{ ' GT1 EXECUTE -> 123 }\r
-{ : GT2 ['] GT1 ; IMMEDIATE -> }\r
-{ GT2 EXECUTE -> 123 }\r
-HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING\r
-HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING\r
-{ GT1STRING FIND -> ' GT1 -1 }\r
-{ GT2STRING FIND -> ' GT2 1 }\r
-( HOW TO SEARCH FOR NON-EXISTENT WORD? )\r
-{ : GT3 GT2 LITERAL ; -> }\r
-{ GT3 -> ' GT1 }\r
-{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }\r
-\r
-{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }\r
-{ : GT5 GT4 ; -> }\r
-{ GT5 -> 123 }\r
-{ : GT6 345 ; IMMEDIATE -> }\r
-{ : GT7 POSTPONE GT6 ; -> }\r
-{ GT7 -> 345 }\r
-\r
-{ : GT8 STATE @ ; IMMEDIATE -> }\r
-{ GT8 -> 0 }\r
-{ : GT9 GT8 LITERAL ; -> }\r
-{ GT9 0= -> <FALSE> }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE\r
-\r
-{ : GI1 IF 123 THEN ; -> }\r
-{ : GI2 IF 123 ELSE 234 THEN ; -> }\r
-{ 0 GI1 -> }\r
-{ 1 GI1 -> 123 }\r
-{ -1 GI1 -> 123 }\r
-{ 0 GI2 -> 234 }\r
-{ 1 GI2 -> 123 }\r
-{ -1 GI1 -> 123 }\r
-\r
-{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }\r
-{ 0 GI3 -> 0 1 2 3 4 5 }\r
-{ 4 GI3 -> 4 5 }\r
-{ 5 GI3 -> 5 }\r
-{ 6 GI3 -> 6 }\r
-\r
-{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }\r
-{ 3 GI4 -> 3 4 5 6 }\r
-{ 5 GI4 -> 5 6 }\r
-{ 6 GI4 -> 6 7 }\r
-\r
-{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }\r
-{ 1 GI5 -> 1 345 }\r
-{ 2 GI5 -> 2 345 }\r
-{ 3 GI5 -> 3 4 5 123 }\r
-{ 4 GI5 -> 4 5 123 }\r
-{ 5 GI5 -> 5 123 }\r
-\r
-{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }\r
-{ 0 GI6 -> 0 }\r
-{ 1 GI6 -> 0 1 }\r
-{ 2 GI6 -> 0 1 2 }\r
-{ 3 GI6 -> 0 1 2 3 }\r
-{ 4 GI6 -> 0 1 2 3 4 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT\r
-\r
-{ : GD1 DO I LOOP ; -> }\r
-{ 4 1 GD1 -> 1 2 3 }\r
-{ 2 -1 GD1 -> -1 0 1 }\r
-{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }\r
-\r
-{ : GD2 DO I -1 +LOOP ; -> }\r
-{ 1 4 GD2 -> 4 3 2 1 }\r
-{ -1 2 GD2 -> 2 1 0 -1 }\r
-{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }\r
-\r
-{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }\r
-{ 4 1 GD3 -> 1 2 3 }\r
-{ 2 -1 GD3 -> -1 0 1 }\r
-{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }\r
-\r
-{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }\r
-{ 1 4 GD4 -> 4 3 2 1 }\r
-{ -1 2 GD4 -> 2 1 0 -1 }\r
-{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }\r
-\r
-{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }\r
-{ 1 GD5 -> 123 }\r
-{ 5 GD5 -> 123 }\r
-{ 6 GD5 -> 234 }\r
-\r
-{ : GD6  ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )\r
-   0 SWAP 0 DO\r
-      I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP\r
-    LOOP ; -> }\r
-{ 1 GD6 -> 1 }\r
-{ 2 GD6 -> 3 }\r
-{ 3 GD6 -> 4 1 2 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY\r
-\r
-{ 123 CONSTANT X123 -> }\r
-{ X123 -> 123 }\r
-{ : EQU CONSTANT ; -> }\r
-{ X123 EQU Y123 -> }\r
-{ Y123 -> 123 }\r
-\r
-{ VARIABLE V1 -> }\r
-{ 123 V1 ! -> }\r
-{ V1 @ -> 123 }\r
-\r
-{ : NOP : POSTPONE ; ; -> }\r
-{ NOP NOP1 NOP NOP2 -> }\r
-{ NOP1 -> }\r
-{ NOP2 -> }\r
-\r
-{ : DOES1 DOES> @ 1 + ; -> }\r
-{ : DOES2 DOES> @ 2 + ; -> }\r
-{ CREATE CR1 -> }\r
-{ CR1 -> HERE }\r
-{ ' CR1 >BODY -> HERE }\r
-{ 1 , -> }\r
-{ CR1 @ -> 1 }\r
-{ DOES1 -> }\r
-{ CR1 -> 2 }\r
-{ DOES2 -> }\r
-{ CR1 -> 3 }\r
-\r
-{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }\r
-{ WEIRD: W1 -> }\r
-{ ' W1 >BODY -> HERE }\r
-{ W1 -> HERE 1 + }\r
-{ W1 -> HERE 2 + }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING EVALUATE\r
-\r
-: GE1 S" 123" ; IMMEDIATE\r
-: GE2 S" 123 1+" ; IMMEDIATE\r
-: GE3 S" : GE4 345 ;" ;\r
-: GE5 EVALUATE ; IMMEDIATE\r
-\r
-{ GE1 EVALUATE -> 123 }                        ( TEST EVALUATE IN INTERP. STATE )\r
-{ GE2 EVALUATE -> 124 }\r
-{ GE3 EVALUATE -> }\r
-{ GE4 -> 345 }\r
-\r
-{ : GE6 GE1 GE5 ; -> }                 ( TEST EVALUATE IN COMPILE STATE )\r
-{ GE6 -> 123 }\r
-{ : GE7 GE2 GE5 ; -> }\r
-{ GE7 -> 124 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING SOURCE >IN WORD\r
-\r
-: GS1 S" SOURCE" 2DUP EVALUATE\r
-       >R SWAP >R = R> R> = ;\r
-{ GS1 -> <TRUE> <TRUE> }\r
-\r
-VARIABLE SCANS\r
-: RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;\r
-\r
-{ 2 SCANS !\r
-345 RESCAN?\r
--> 345 345 }\r
-\r
-: GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;\r
-{ GS2 -> 123 123 123 123 123 }\r
-\r
-: GS3 WORD COUNT SWAP C@ ;\r
-{ BL GS3 HELLO -> 5 CHAR H }\r
-{ CHAR " GS3 GOODBYE" -> 7 CHAR G }\r
-{ BL GS3\r
-DROP -> 0 }                            \ BLANK LINE RETURN ZERO-LENGTH STRING\r
-\r
-: GS4 SOURCE >IN ! DROP ;\r
-{ GS4 123 456\r
--> }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL\r
-\r
-: S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.\r
-   >R SWAP R@ = IF                     \ MAKE SURE STRINGS HAVE SAME LENGTH\r
-      R> ?DUP IF                       \ IF NON-EMPTY STRINGS\r
-        0 DO\r
-           OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN\r
-           SWAP CHAR+ SWAP CHAR+\r
-         LOOP\r
-      THEN\r
-      2DROP <TRUE>                     \ IF WE GET HERE, STRINGS MATCH\r
-   ELSE\r
-      R> DROP 2DROP <FALSE>            \ LENGTHS MISMATCH\r
-   THEN ;\r
-\r
-: GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;\r
-{ GP1 -> <TRUE> }\r
-\r
-: GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;\r
-{ GP2 -> <TRUE> }\r
-\r
-: GP3  <# 1 0 # # #> S" 01" S= ;\r
-{ GP3 -> <TRUE> }\r
-\r
-: GP4  <# 1 0 #S #> S" 1" S= ;\r
-{ GP4 -> <TRUE> }\r
-\r
-24 CONSTANT MAX-BASE                   \ BASE 2 .. 36\r
-: COUNT-BITS\r
-   0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;\r
-COUNT-BITS 2* CONSTANT #BITS-UD                \ NUMBER OF BITS IN UD\r
-\r
-: GP5\r
-   BASE @ <TRUE>\r
-   MAX-BASE 1+ 2 DO                    \ FOR EACH POSSIBLE BASE\r
-      I BASE !                         \ TBD: ASSUMES BASE WORKS\r
-      I 0 <# #S #> S" 10" S= AND\r
-   LOOP\r
-   SWAP BASE ! ;\r
-{ GP5 -> <TRUE> }\r
-\r
-: GP6\r
-   BASE @ >R  2 BASE !\r
-   MAX-UINT MAX-UINT <# #S #>          \ MAXIMUM UD TO BINARY\r
-   R> BASE !                           \ S: C-ADDR U\r
-   DUP #BITS-UD = SWAP\r
-   0 DO                                        \ S: C-ADDR FLAG\r
-      OVER C@ [CHAR] 1 = AND           \ ALL ONES\r
-      >R CHAR+ R>\r
-   LOOP SWAP DROP ;\r
-{ GP6 -> <TRUE> }\r
-\r
-: GP7\r
-   BASE @ >R    MAX-BASE BASE !\r
-   <TRUE>\r
-   A 0 DO\r
-      I 0 <# #S #>\r
-      1 = SWAP C@ I 30 + = AND AND\r
-   LOOP\r
-   MAX-BASE A DO\r
-      I 0 <# #S #>\r
-      1 = SWAP C@ 41 I A - + = AND AND\r
-   LOOP\r
-   R> BASE ! ;\r
-\r
-{ GP7 -> <TRUE> }\r
-\r
-\ >NUMBER TESTS\r
-CREATE GN-BUF 0 C,\r
-: GN-STRING    GN-BUF 1 ;\r
-: GN-CONSUMED  GN-BUF CHAR+ 0 ;\r
-: GN'          [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;\r
-\r
-{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }\r
-{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }\r
-{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }\r
-{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }        \ SHOULD FAIL TO CONVERT THESE\r
-{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }\r
-{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }\r
-\r
-: >NUMBER-BASED\r
-   BASE @ >R BASE ! >NUMBER R> BASE ! ;\r
-\r
-{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }\r
-{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }\r
-{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }\r
-{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }\r
-{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }\r
-{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }\r
-\r
-: GN1  \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.\r
-   BASE @ >R BASE !\r
-   <# #S #>\r
-   0 0 2SWAP >NUMBER SWAP DROP         \ RETURN LENGTH ONLY\r
-   R> BASE ! ;\r
-{ 0 0 2 GN1 -> 0 0 0 }\r
-{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }\r
-{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }\r
-{ 0 0 MAX-BASE GN1 -> 0 0 0 }\r
-{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }\r
-{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }\r
-\r
-: GN2  \ ( -- 16 10 )\r
-   BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;\r
-{ GN2 -> 10 A }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING FILL MOVE\r
-\r
-CREATE FBUF 00 C, 00 C, 00 C,\r
-CREATE SBUF 12 C, 34 C, 56 C,\r
-: SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;\r
-\r
-{ FBUF 0 20 FILL -> }\r
-{ SEEBUF -> 00 00 00 }\r
-\r
-{ FBUF 1 20 FILL -> }\r
-{ SEEBUF -> 20 00 00 }\r
-\r
-{ FBUF 3 20 FILL -> }\r
-{ SEEBUF -> 20 20 20 }\r
-\r
-{ FBUF FBUF 3 CHARS MOVE -> }          \ BIZARRE SPECIAL CASE\r
-{ SEEBUF -> 20 20 20 }\r
-\r
-{ SBUF FBUF 0 CHARS MOVE -> }\r
-{ SEEBUF -> 20 20 20 }\r
-\r
-{ SBUF FBUF 1 CHARS MOVE -> }\r
-{ SEEBUF -> 12 20 20 }\r
-\r
-{ SBUF FBUF 3 CHARS MOVE -> }\r
-{ SEEBUF -> 12 34 56 }\r
-\r
-{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }\r
-{ SEEBUF -> 12 12 34 }\r
-\r
-{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }\r
-{ SEEBUF -> 12 34 34 }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.\r
-\r
-: OUTPUT-TEST\r
-   ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR\r
-   41 BL DO I EMIT LOOP CR\r
-   61 41 DO I EMIT LOOP CR\r
-   7F 61 DO I EMIT LOOP CR\r
-   ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR\r
-   9 1+ 0 DO I . LOOP CR\r
-   ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR\r
-   [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR\r
-   ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR\r
-   [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR\r
-   ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR\r
-   5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR\r
-   ." YOU SHOULD SEE TWO SEPARATE LINES:" CR\r
-   S" LINE 1" TYPE CR S" LINE 2" TYPE CR\r
-   ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR\r
-   ."   SIGNED: " MIN-INT . MAX-INT . CR\r
-   ." UNSIGNED: " 0 U. MAX-UINT U. CR\r
-;\r
-\r
-{ OUTPUT-TEST -> }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING INPUT: ACCEPT\r
-\r
-CREATE ABUF 80 CHARS ALLOT\r
-\r
-: ACCEPT-TEST\r
-   CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR\r
-   ABUF 80 ACCEPT\r
-   CR ." RECEIVED: " [CHAR] " EMIT\r
-   ABUF SWAP TYPE [CHAR] " EMIT CR\r
-;\r
-\r
-{ ACCEPT-TEST -> }\r
-\r
-\ ------------------------------------------------------------------------\r
-TESTING DICTIONARY SEARCH RULES\r
-\r
-{ : GDX   123 ; : GDX   GDX 234 ; -> }\r
-\r
-{ GDX -> 123 234 }\r
-\r
-\r
+\ From: John Hayes S1I
+\ Subject: core.fr
+\ Date: Mon, 27 Nov 95 13:10
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.2
+\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
+\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
+\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
+\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
+\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
+\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
+
+\ Load test tools - Phil Burk
+include? testing tester.fth
+
+TESTING CORE WORDS
+HEX
+
+\ ------------------------------------------------------------------------
+TESTING BASIC ASSUMPTIONS
+
+{ -> }                  \ START WITH CLEAN SLATE
+( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
+{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
+{  0 BITSSET? -> 0 }        ( ZERO IS ALL BITS CLEAR )
+{  1 BITSSET? -> 0 0 }      ( OTHER NUMBER HAVE AT LEAST ONE BIT )
+{ -1 BITSSET? -> 0 0 }
+
+\ ------------------------------------------------------------------------
+TESTING BOOLEANS: INVERT AND OR XOR
+
+{ 0 0 AND -> 0 }
+{ 0 1 AND -> 0 }
+{ 1 0 AND -> 0 }
+{ 1 1 AND -> 1 }
+
+{ 0 INVERT 1 AND -> 1 }
+{ 1 INVERT 1 AND -> 0 }
+
+0    CONSTANT 0S
+0 INVERT CONSTANT 1S
+
+{ 0S INVERT -> 1S }
+{ 1S INVERT -> 0S }
+
+{ 0S 0S AND -> 0S }
+{ 0S 1S AND -> 0S }
+{ 1S 0S AND -> 0S }
+{ 1S 1S AND -> 1S }
+
+{ 0S 0S OR -> 0S }
+{ 0S 1S OR -> 1S }
+{ 1S 0S OR -> 1S }
+{ 1S 1S OR -> 1S }
+
+{ 0S 0S XOR -> 0S }
+{ 0S 1S XOR -> 1S }
+{ 1S 0S XOR -> 1S }
+{ 1S 1S XOR -> 0S }
+
+\ ------------------------------------------------------------------------
+TESTING 2* 2/ LSHIFT RSHIFT
+
+( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
+1S 1 RSHIFT INVERT CONSTANT MSB
+{ MSB BITSSET? -> 0 0 }
+
+{ 0S 2* -> 0S }
+{ 1 2* -> 2 }
+{ 4000 2* -> 8000 }
+{ 1S 2* 1 XOR -> 1S }
+{ MSB 2* -> 0S }
+
+{ 0S 2/ -> 0S }
+{ 1 2/ -> 0 }
+{ 4000 2/ -> 2000 }
+{ 1S 2/ -> 1S }             \ MSB PROPOGATED
+{ 1S 1 XOR 2/ -> 1S }
+{ MSB 2/ MSB AND -> MSB }
+
+{ 1 0 LSHIFT -> 1 }
+{ 1 1 LSHIFT -> 2 }
+{ 1 2 LSHIFT -> 4 }
+{ 1 F LSHIFT -> 8000 }          \ BIGGEST GUARANTEED SHIFT
+{ 1S 1 LSHIFT 1 XOR -> 1S }
+{ MSB 1 LSHIFT -> 0 }
+
+{ 1 0 RSHIFT -> 1 }
+{ 1 1 RSHIFT -> 0 }
+{ 2 1 RSHIFT -> 1 }
+{ 4 2 RSHIFT -> 1 }
+{ 8000 F RSHIFT -> 1 }          \ BIGGEST
+{ MSB 1 RSHIFT MSB AND -> 0 }       \ RSHIFT ZERO FILLS MSBS
+{ MSB 1 RSHIFT 2* -> MSB }
+
+\ ------------------------------------------------------------------------
+TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
+0 INVERT            CONSTANT MAX-UINT
+0 INVERT 1 RSHIFT       CONSTANT MAX-INT
+0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT
+0 INVERT 1 RSHIFT       CONSTANT MID-UINT
+0 INVERT 1 RSHIFT INVERT    CONSTANT MID-UINT+1
+
+0S CONSTANT <FALSE>
+1S CONSTANT <TRUE>
+
+{ 0 0= -> <TRUE> }
+{ 1 0= -> <FALSE> }
+{ 2 0= -> <FALSE> }
+{ -1 0= -> <FALSE> }
+{ MAX-UINT 0= -> <FALSE> }
+{ MIN-INT 0= -> <FALSE> }
+{ MAX-INT 0= -> <FALSE> }
+
+{ 0 0 = -> <TRUE> }
+{ 1 1 = -> <TRUE> }
+{ -1 -1 = -> <TRUE> }
+{ 1 0 = -> <FALSE> }
+{ -1 0 = -> <FALSE> }
+{ 0 1 = -> <FALSE> }
+{ 0 -1 = -> <FALSE> }
+
+{ 0 0< -> <FALSE> }
+{ -1 0< -> <TRUE> }
+{ MIN-INT 0< -> <TRUE> }
+{ 1 0< -> <FALSE> }
+{ MAX-INT 0< -> <FALSE> }
+
+{ 0 1 < -> <TRUE> }
+{ 1 2 < -> <TRUE> }
+{ -1 0 < -> <TRUE> }
+{ -1 1 < -> <TRUE> }
+{ MIN-INT 0 < -> <TRUE> }
+{ MIN-INT MAX-INT < -> <TRUE> }
+{ 0 MAX-INT < -> <TRUE> }
+{ 0 0 < -> <FALSE> }
+{ 1 1 < -> <FALSE> }
+{ 1 0 < -> <FALSE> }
+{ 2 1 < -> <FALSE> }
+{ 0 -1 < -> <FALSE> }
+{ 1 -1 < -> <FALSE> }
+{ 0 MIN-INT < -> <FALSE> }
+{ MAX-INT MIN-INT < -> <FALSE> }
+{ MAX-INT 0 < -> <FALSE> }
+
+{ 0 1 > -> <FALSE> }
+{ 1 2 > -> <FALSE> }
+{ -1 0 > -> <FALSE> }
+{ -1 1 > -> <FALSE> }
+{ MIN-INT 0 > -> <FALSE> }
+{ MIN-INT MAX-INT > -> <FALSE> }
+{ 0 MAX-INT > -> <FALSE> }
+{ 0 0 > -> <FALSE> }
+{ 1 1 > -> <FALSE> }
+{ 1 0 > -> <TRUE> }
+{ 2 1 > -> <TRUE> }
+{ 0 -1 > -> <TRUE> }
+{ 1 -1 > -> <TRUE> }
+{ 0 MIN-INT > -> <TRUE> }
+{ MAX-INT MIN-INT > -> <TRUE> }
+{ MAX-INT 0 > -> <TRUE> }
+
+{ 0 1 U< -> <TRUE> }
+{ 1 2 U< -> <TRUE> }
+{ 0 MID-UINT U< -> <TRUE> }
+{ 0 MAX-UINT U< -> <TRUE> }
+{ MID-UINT MAX-UINT U< -> <TRUE> }
+{ 0 0 U< -> <FALSE> }
+{ 1 1 U< -> <FALSE> }
+{ 1 0 U< -> <FALSE> }
+{ 2 1 U< -> <FALSE> }
+{ MID-UINT 0 U< -> <FALSE> }
+{ MAX-UINT 0 U< -> <FALSE> }
+{ MAX-UINT MID-UINT U< -> <FALSE> }
+
+{ 0 1 MIN -> 0 }
+{ 1 2 MIN -> 1 }
+{ -1 0 MIN -> -1 }
+{ -1 1 MIN -> -1 }
+{ MIN-INT 0 MIN -> MIN-INT }
+{ MIN-INT MAX-INT MIN -> MIN-INT }
+{ 0 MAX-INT MIN -> 0 }
+{ 0 0 MIN -> 0 }
+{ 1 1 MIN -> 1 }
+{ 1 0 MIN -> 0 }
+{ 2 1 MIN -> 1 }
+{ 0 -1 MIN -> -1 }
+{ 1 -1 MIN -> -1 }
+{ 0 MIN-INT MIN -> MIN-INT }
+{ MAX-INT MIN-INT MIN -> MIN-INT }
+{ MAX-INT 0 MIN -> 0 }
+
+{ 0 1 MAX -> 1 }
+{ 1 2 MAX -> 2 }
+{ -1 0 MAX -> 0 }
+{ -1 1 MAX -> 1 }
+{ MIN-INT 0 MAX -> 0 }
+{ MIN-INT MAX-INT MAX -> MAX-INT }
+{ 0 MAX-INT MAX -> MAX-INT }
+{ 0 0 MAX -> 0 }
+{ 1 1 MAX -> 1 }
+{ 1 0 MAX -> 1 }
+{ 2 1 MAX -> 2 }
+{ 0 -1 MAX -> 0 }
+{ 1 -1 MAX -> 1 }
+{ 0 MIN-INT MAX -> 0 }
+{ MAX-INT MIN-INT MAX -> MAX-INT }
+{ MAX-INT 0 MAX -> MAX-INT }
+
+\ ------------------------------------------------------------------------
+TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
+
+{ 1 2 2DROP -> }
+{ 1 2 2DUP -> 1 2 1 2 }
+{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
+{ 1 2 3 4 2SWAP -> 3 4 1 2 }
+{ 0 ?DUP -> 0 }
+{ 1 ?DUP -> 1 1 }
+{ -1 ?DUP -> -1 -1 }
+{ DEPTH -> 0 }
+{ 0 DEPTH -> 0 1 }
+{ 0 1 DEPTH -> 0 1 2 }
+{ 0 DROP -> }
+{ 1 2 DROP -> 1 }
+{ 1 DUP -> 1 1 }
+{ 1 2 OVER -> 1 2 1 }
+{ 1 2 3 ROT -> 2 3 1 }
+{ 1 2 SWAP -> 2 1 }
+
+\ ------------------------------------------------------------------------
+TESTING >R R> R@
+
+{ : GR1 >R R> ; -> }
+{ : GR2 >R R@ R> DROP ; -> }
+{ 123 GR1 -> 123 }
+{ 123 GR2 -> 123 }
+{ 1S GR1 -> 1S }   ( RETURN STACK HOLDS CELLS )
+
+\ ------------------------------------------------------------------------
+TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
+
+{ 0 5 + -> 5 }
+{ 5 0 + -> 5 }
+{ 0 -5 + -> -5 }
+{ -5 0 + -> -5 }
+{ 1 2 + -> 3 }
+{ 1 -2 + -> -1 }
+{ -1 2 + -> 1 }
+{ -1 -2 + -> -3 }
+{ -1 1 + -> 0 }
+{ MID-UINT 1 + -> MID-UINT+1 }
+
+{ 0 5 - -> -5 }
+{ 5 0 - -> 5 }
+{ 0 -5 - -> 5 }
+{ -5 0 - -> -5 }
+{ 1 2 - -> -1 }
+{ 1 -2 - -> 3 }
+{ -1 2 - -> -3 }
+{ -1 -2 - -> 1 }
+{ 0 1 - -> -1 }
+{ MID-UINT+1 1 - -> MID-UINT }
+
+{ 0 1+ -> 1 }
+{ -1 1+ -> 0 }
+{ 1 1+ -> 2 }
+{ MID-UINT 1+ -> MID-UINT+1 }
+
+{ 2 1- -> 1 }
+{ 1 1- -> 0 }
+{ 0 1- -> -1 }
+{ MID-UINT+1 1- -> MID-UINT }
+
+{ 0 NEGATE -> 0 }
+{ 1 NEGATE -> -1 }
+{ -1 NEGATE -> 1 }
+{ 2 NEGATE -> -2 }
+{ -2 NEGATE -> 2 }
+
+{ 0 ABS -> 0 }
+{ 1 ABS -> 1 }
+{ -1 ABS -> 1 }
+{ MIN-INT ABS -> MID-UINT+1 }
+
+\ ------------------------------------------------------------------------
+TESTING MULTIPLY: S>D * M* UM*
+
+{ 0 S>D -> 0 0 }
+{ 1 S>D -> 1 0 }
+{ 2 S>D -> 2 0 }
+{ -1 S>D -> -1 -1 }
+{ -2 S>D -> -2 -1 }
+{ MIN-INT S>D -> MIN-INT -1 }
+{ MAX-INT S>D -> MAX-INT 0 }
+
+{ 0 0 M* -> 0 S>D }
+{ 0 1 M* -> 0 S>D }
+{ 1 0 M* -> 0 S>D }
+{ 1 2 M* -> 2 S>D }
+{ 2 1 M* -> 2 S>D }
+{ 3 3 M* -> 9 S>D }
+{ -3 3 M* -> -9 S>D }
+{ 3 -3 M* -> -9 S>D }
+{ -3 -3 M* -> 9 S>D }
+{ 0 MIN-INT M* -> 0 S>D }
+{ 1 MIN-INT M* -> MIN-INT S>D }
+{ 2 MIN-INT M* -> 0 1S }
+{ 0 MAX-INT M* -> 0 S>D }
+{ 1 MAX-INT M* -> MAX-INT S>D }
+{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
+{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
+{ MAX-INT MIN-INT M* -> MSB MSB 2/ }
+{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
+
+{ 0 0 * -> 0 }              \ TEST IDENTITIES
+{ 0 1 * -> 0 }
+{ 1 0 * -> 0 }
+{ 1 2 * -> 2 }
+{ 2 1 * -> 2 }
+{ 3 3 * -> 9 }
+{ -3 3 * -> -9 }
+{ 3 -3 * -> -9 }
+{ -3 -3 * -> 9 }
+
+{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
+{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
+{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
+
+{ 0 0 UM* -> 0 0 }
+{ 0 1 UM* -> 0 0 }
+{ 1 0 UM* -> 0 0 }
+{ 1 2 UM* -> 2 0 }
+{ 2 1 UM* -> 2 0 }
+{ 3 3 UM* -> 9 0 }
+
+{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
+{ MID-UINT+1 2 UM* -> 0 1 }
+{ MID-UINT+1 4 UM* -> 0 2 }
+{ 1S 2 UM* -> 1S 1 LSHIFT 1 }
+{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
+
+\ ------------------------------------------------------------------------
+TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
+
+{ 0 S>D 1 FM/MOD -> 0 0 }
+{ 1 S>D 1 FM/MOD -> 0 1 }
+{ 2 S>D 1 FM/MOD -> 0 2 }
+{ -1 S>D 1 FM/MOD -> 0 -1 }
+{ -2 S>D 1 FM/MOD -> 0 -2 }
+{ 0 S>D -1 FM/MOD -> 0 0 }
+{ 1 S>D -1 FM/MOD -> 0 -1 }
+{ 2 S>D -1 FM/MOD -> 0 -2 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -1 FM/MOD -> 0 2 }
+{ 2 S>D 2 FM/MOD -> 0 1 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -2 FM/MOD -> 0 1 }
+{  7 S>D  3 FM/MOD -> 1 2 }
+{  7 S>D -3 FM/MOD -> -2 -3 }
+{ -7 S>D  3 FM/MOD -> 2 -3 }
+{ -7 S>D -3 FM/MOD -> -1 2 }
+{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
+{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
+{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
+{ 1S 1 4 FM/MOD -> 3 MAX-INT }
+{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
+{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
+{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
+{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
+{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
+{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
+
+{ 0 S>D 1 SM/REM -> 0 0 }
+{ 1 S>D 1 SM/REM -> 0 1 }
+{ 2 S>D 1 SM/REM -> 0 2 }
+{ -1 S>D 1 SM/REM -> 0 -1 }
+{ -2 S>D 1 SM/REM -> 0 -2 }
+{ 0 S>D -1 SM/REM -> 0 0 }
+{ 1 S>D -1 SM/REM -> 0 -1 }
+{ 2 S>D -1 SM/REM -> 0 -2 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -1 SM/REM -> 0 2 }
+{ 2 S>D 2 SM/REM -> 0 1 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -2 SM/REM -> 0 1 }
+{  7 S>D  3 SM/REM -> 1 2 }
+{  7 S>D -3 SM/REM -> 1 -2 }
+{ -7 S>D  3 SM/REM -> -1 -2 }
+{ -7 S>D -3 SM/REM -> -1 2 }
+{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
+{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }
+{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }
+{ 1S 1 4 SM/REM -> 3 MAX-INT }
+{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
+{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
+
+{ 0 0 1 UM/MOD -> 0 0 }
+{ 1 0 1 UM/MOD -> 0 1 }
+{ 1 0 2 UM/MOD -> 1 0 }
+{ 3 0 2 UM/MOD -> 1 1 }
+{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
+{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
+{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
+
+: IFFLOORED
+   [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+: IFSYM
+   [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+
+\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
+\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
+IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
+IFFLOORED : T/     T/MOD SWAP DROP ;
+IFFLOORED : TMOD   T/MOD DROP ;
+IFFLOORED : T*/MOD >R M* R> FM/MOD ;
+IFFLOORED : T*/    T*/MOD SWAP DROP ;
+IFSYM     : T/MOD  >R S>D R> SM/REM ;
+IFSYM     : T/     T/MOD SWAP DROP ;
+IFSYM     : TMOD   T/MOD DROP ;
+IFSYM     : T*/MOD >R M* R> SM/REM ;
+IFSYM     : T*/    T*/MOD SWAP DROP ;
+
+{ 0 1 /MOD -> 0 1 T/MOD }
+{ 1 1 /MOD -> 1 1 T/MOD }
+{ 2 1 /MOD -> 2 1 T/MOD }
+{ -1 1 /MOD -> -1 1 T/MOD }
+{ -2 1 /MOD -> -2 1 T/MOD }
+{ 0 -1 /MOD -> 0 -1 T/MOD }
+{ 1 -1 /MOD -> 1 -1 T/MOD }
+{ 2 -1 /MOD -> 2 -1 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -1 /MOD -> -2 -1 T/MOD }
+{ 2 2 /MOD -> 2 2 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -2 /MOD -> -2 -2 T/MOD }
+{ 7 3 /MOD -> 7 3 T/MOD }
+{ 7 -3 /MOD -> 7 -3 T/MOD }
+{ -7 3 /MOD -> -7 3 T/MOD }
+{ -7 -3 /MOD -> -7 -3 T/MOD }
+{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
+{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
+{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
+{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
+
+{ 0 1 / -> 0 1 T/ }
+{ 1 1 / -> 1 1 T/ }
+{ 2 1 / -> 2 1 T/ }
+{ -1 1 / -> -1 1 T/ }
+{ -2 1 / -> -2 1 T/ }
+{ 0 -1 / -> 0 -1 T/ }
+{ 1 -1 / -> 1 -1 T/ }
+{ 2 -1 / -> 2 -1 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -1 / -> -2 -1 T/ }
+{ 2 2 / -> 2 2 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -2 / -> -2 -2 T/ }
+{ 7 3 / -> 7 3 T/ }
+{ 7 -3 / -> 7 -3 T/ }
+{ -7 3 / -> -7 3 T/ }
+{ -7 -3 / -> -7 -3 T/ }
+{ MAX-INT 1 / -> MAX-INT 1 T/ }
+{ MIN-INT 1 / -> MIN-INT 1 T/ }
+{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
+{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
+
+{ 0 1 MOD -> 0 1 TMOD }
+{ 1 1 MOD -> 1 1 TMOD }
+{ 2 1 MOD -> 2 1 TMOD }
+{ -1 1 MOD -> -1 1 TMOD }
+{ -2 1 MOD -> -2 1 TMOD }
+{ 0 -1 MOD -> 0 -1 TMOD }
+{ 1 -1 MOD -> 1 -1 TMOD }
+{ 2 -1 MOD -> 2 -1 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -1 MOD -> -2 -1 TMOD }
+{ 2 2 MOD -> 2 2 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -2 MOD -> -2 -2 TMOD }
+{ 7 3 MOD -> 7 3 TMOD }
+{ 7 -3 MOD -> 7 -3 TMOD }
+{ -7 3 MOD -> -7 3 TMOD }
+{ -7 -3 MOD -> -7 -3 TMOD }
+{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }
+{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }
+{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
+{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
+
+{ 0 2 1 */ -> 0 2 1 T*/ }
+{ 1 2 1 */ -> 1 2 1 T*/ }
+{ 2 2 1 */ -> 2 2 1 T*/ }
+{ -1 2 1 */ -> -1 2 1 T*/ }
+{ -2 2 1 */ -> -2 2 1 T*/ }
+{ 0 2 -1 */ -> 0 2 -1 T*/ }
+{ 1 2 -1 */ -> 1 2 -1 T*/ }
+{ 2 2 -1 */ -> 2 2 -1 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -1 */ -> -2 2 -1 T*/ }
+{ 2 2 2 */ -> 2 2 2 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -2 */ -> -2 2 -2 T*/ }
+{ 7 2 3 */ -> 7 2 3 T*/ }
+{ 7 2 -3 */ -> 7 2 -3 T*/ }
+{ -7 2 3 */ -> -7 2 3 T*/ }
+{ -7 2 -3 */ -> -7 2 -3 T*/ }
+{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
+{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
+
+{ 0 2 1 */MOD -> 0 2 1 T*/MOD }
+{ 1 2 1 */MOD -> 1 2 1 T*/MOD }
+{ 2 2 1 */MOD -> 2 2 1 T*/MOD }
+{ -1 2 1 */MOD -> -1 2 1 T*/MOD }
+{ -2 2 1 */MOD -> -2 2 1 T*/MOD }
+{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
+{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
+{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
+{ 2 2 2 */MOD -> 2 2 2 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
+{ 7 2 3 */MOD -> 7 2 3 T*/MOD }
+{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
+{ -7 2 3 */MOD -> -7 2 3 T*/MOD }
+{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
+{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
+{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
+
+\ ------------------------------------------------------------------------
+TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
+
+HERE 1 ALLOT
+HERE
+CONSTANT 2NDA
+CONSTANT 1STA
+{ 1STA 2NDA U< -> <TRUE> }      \ HERE MUST GROW WITH ALLOT
+{ 1STA 1+ -> 2NDA }         \ ... BY ONE ADDRESS UNIT
+( MISSING TEST: NEGATIVE ALLOT )
+
+HERE 1 ,
+HERE 2 ,
+CONSTANT 2ND
+CONSTANT 1ST
+{ 1ST 2ND U< -> <TRUE> }            \ HERE MUST GROW WITH ALLOT
+{ 1ST CELL+ -> 2ND }            \ ... BY ONE CELL
+{ 1ST 1 CELLS + -> 2ND }
+{ 1ST @ 2ND @ -> 1 2 }
+{ 5 1ST ! -> }
+{ 1ST @ 2ND @ -> 5 2 }
+{ 6 2ND ! -> }
+{ 1ST @ 2ND @ -> 5 6 }
+{ 1ST 2@ -> 6 5 }
+{ 2 1 1ST 2! -> }
+{ 1ST 2@ -> 2 1 }
+{ 1S 1ST !  1ST @ -> 1S }       \ CAN STORE CELL-WIDE VALUE
+
+HERE 1 C,
+HERE 2 C,
+CONSTANT 2NDC
+CONSTANT 1STC
+{ 1STC 2NDC U< -> <TRUE> }      \ HERE MUST GROW WITH ALLOT
+{ 1STC CHAR+ -> 2NDC }          \ ... BY ONE CHAR
+{ 1STC 1 CHARS + -> 2NDC }
+{ 1STC C@ 2NDC C@ -> 1 2 }
+{ 3 1STC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 2 }
+{ 4 2NDC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 4 }
+
+ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
+CONSTANT A-ADDR  CONSTANT UA-ADDR
+{ UA-ADDR ALIGNED -> A-ADDR }
+{    1 A-ADDR C!  A-ADDR C@ ->    1 }
+{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }
+{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }
+{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }
+{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }
+{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }
+{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }
+
+: BITS ( X -- U )
+   0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
+( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
+{ 1 CHARS 1 < -> <FALSE> }
+{ 1 CHARS 1 CELLS > -> <FALSE> }
+( TBD: HOW TO FIND NUMBER OF BITS? )
+
+( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
+{ 1 CELLS 1 < -> <FALSE> }
+{ 1 CELLS 1 CHARS MOD -> 0 }
+{ 1S BITS 10 < -> <FALSE> }
+
+{ 0 1ST ! -> }
+{ 1 1ST +! -> }
+{ 1ST @ -> 1 }
+{ -1 1ST +! 1ST @ -> 0 }
+
+\ ------------------------------------------------------------------------
+TESTING CHAR [CHAR] [ ] BL S"
+
+{ BL -> 20 }
+{ CHAR X -> 58 }
+{ CHAR HELLO -> 48 }
+{ : GC1 [CHAR] X ; -> }
+{ : GC2 [CHAR] HELLO ; -> }
+{ GC1 -> 58 }
+{ GC2 -> 48 }
+{ : GC3 [ GC1 ] LITERAL ; -> }
+{ GC3 -> 58 }
+{ : GC4 S" XY" ; -> }
+{ GC4 SWAP DROP -> 2 }
+{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
+
+\ ------------------------------------------------------------------------
+TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
+
+{ : GT1 123 ; -> }
+{ ' GT1 EXECUTE -> 123 }
+{ : GT2 ['] GT1 ; IMMEDIATE -> }
+{ GT2 EXECUTE -> 123 }
+HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
+HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
+{ GT1STRING FIND -> ' GT1 -1 }
+{ GT2STRING FIND -> ' GT2 1 }
+( HOW TO SEARCH FOR NON-EXISTENT WORD? )
+{ : GT3 GT2 LITERAL ; -> }
+{ GT3 -> ' GT1 }
+{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }
+
+{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }
+{ : GT5 GT4 ; -> }
+{ GT5 -> 123 }
+{ : GT6 345 ; IMMEDIATE -> }
+{ : GT7 POSTPONE GT6 ; -> }
+{ GT7 -> 345 }
+
+{ : GT8 STATE @ ; IMMEDIATE -> }
+{ GT8 -> 0 }
+{ : GT9 GT8 LITERAL ; -> }
+{ GT9 0= -> <FALSE> }
+
+\ ------------------------------------------------------------------------
+TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
+
+{ : GI1 IF 123 THEN ; -> }
+{ : GI2 IF 123 ELSE 234 THEN ; -> }
+{ 0 GI1 -> }
+{ 1 GI1 -> 123 }
+{ -1 GI1 -> 123 }
+{ 0 GI2 -> 234 }
+{ 1 GI2 -> 123 }
+{ -1 GI1 -> 123 }
+
+{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
+{ 0 GI3 -> 0 1 2 3 4 5 }
+{ 4 GI3 -> 4 5 }
+{ 5 GI3 -> 5 }
+{ 6 GI3 -> 6 }
+
+{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
+{ 3 GI4 -> 3 4 5 6 }
+{ 5 GI4 -> 5 6 }
+{ 6 GI4 -> 6 7 }
+
+{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
+{ 1 GI5 -> 1 345 }
+{ 2 GI5 -> 2 345 }
+{ 3 GI5 -> 3 4 5 123 }
+{ 4 GI5 -> 4 5 123 }
+{ 5 GI5 -> 5 123 }
+
+{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
+{ 0 GI6 -> 0 }
+{ 1 GI6 -> 0 1 }
+{ 2 GI6 -> 0 1 2 }
+{ 3 GI6 -> 0 1 2 3 }
+{ 4 GI6 -> 0 1 2 3 4 }
+
+\ ------------------------------------------------------------------------
+TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
+
+{ : GD1 DO I LOOP ; -> }
+{ 4 1 GD1 -> 1 2 3 }
+{ 2 -1 GD1 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }
+
+{ : GD2 DO I -1 +LOOP ; -> }
+{ 1 4 GD2 -> 4 3 2 1 }
+{ -1 2 GD2 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
+
+{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }
+{ 4 1 GD3 -> 1 2 3 }
+{ 2 -1 GD3 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }
+
+{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
+{ 1 4 GD4 -> 4 3 2 1 }
+{ -1 2 GD4 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
+
+{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
+{ 1 GD5 -> 123 }
+{ 5 GD5 -> 123 }
+{ 6 GD5 -> 234 }
+
+{ : GD6  ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
+   0 SWAP 0 DO
+      I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
+    LOOP ; -> }
+{ 1 GD6 -> 1 }
+{ 2 GD6 -> 3 }
+{ 3 GD6 -> 4 1 2 }
+
+\ ------------------------------------------------------------------------
+TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
+
+{ 123 CONSTANT X123 -> }
+{ X123 -> 123 }
+{ : EQU CONSTANT ; -> }
+{ X123 EQU Y123 -> }
+{ Y123 -> 123 }
+
+{ VARIABLE V1 -> }
+{ 123 V1 ! -> }
+{ V1 @ -> 123 }
+
+{ : NOP : POSTPONE ; ; -> }
+{ NOP NOP1 NOP NOP2 -> }
+{ NOP1 -> }
+{ NOP2 -> }
+
+{ : DOES1 DOES> @ 1 + ; -> }
+{ : DOES2 DOES> @ 2 + ; -> }
+{ CREATE CR1 -> }
+{ CR1 -> HERE }
+{ ' CR1 >BODY -> HERE }
+{ 1 , -> }
+{ CR1 @ -> 1 }
+{ DOES1 -> }
+{ CR1 -> 2 }
+{ DOES2 -> }
+{ CR1 -> 3 }
+
+{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
+{ WEIRD: W1 -> }
+{ ' W1 >BODY -> HERE }
+{ W1 -> HERE 1 + }
+{ W1 -> HERE 2 + }
+
+\ ------------------------------------------------------------------------
+TESTING EVALUATE
+
+: GE1 S" 123" ; IMMEDIATE
+: GE2 S" 123 1+" ; IMMEDIATE
+: GE3 S" : GE4 345 ;" ;
+: GE5 EVALUATE ; IMMEDIATE
+
+{ GE1 EVALUATE -> 123 }         ( TEST EVALUATE IN INTERP. STATE )
+{ GE2 EVALUATE -> 124 }
+{ GE3 EVALUATE -> }
+{ GE4 -> 345 }
+
+{ : GE6 GE1 GE5 ; -> }          ( TEST EVALUATE IN COMPILE STATE )
+{ GE6 -> 123 }
+{ : GE7 GE2 GE5 ; -> }
+{ GE7 -> 124 }
+
+\ ------------------------------------------------------------------------
+TESTING SOURCE >IN WORD
+
+: GS1 S" SOURCE" 2DUP EVALUATE
+       >R SWAP >R = R> R> = ;
+{ GS1 -> <TRUE> <TRUE> }
+
+VARIABLE SCANS
+: RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
+
+{ 2 SCANS !
+345 RESCAN?
+-> 345 345 }
+
+: GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
+{ GS2 -> 123 123 123 123 123 }
+
+: GS3 WORD COUNT SWAP C@ ;
+{ BL GS3 HELLO -> 5 CHAR H }
+{ CHAR " GS3 GOODBYE" -> 7 CHAR G }
+{ BL GS3
+DROP -> 0 }             \ BLANK LINE RETURN ZERO-LENGTH STRING
+
+: GS4 SOURCE >IN ! DROP ;
+{ GS4 123 456
+-> }
+
+\ ------------------------------------------------------------------------
+TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
+
+: S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
+   >R SWAP R@ = IF          \ MAKE SURE STRINGS HAVE SAME LENGTH
+      R> ?DUP IF            \ IF NON-EMPTY STRINGS
+     0 DO
+        OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
+        SWAP CHAR+ SWAP CHAR+
+         LOOP
+      THEN
+      2DROP <TRUE>          \ IF WE GET HERE, STRINGS MATCH
+   ELSE
+      R> DROP 2DROP <FALSE>     \ LENGTHS MISMATCH
+   THEN ;
+
+: GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+{ GP1 -> <TRUE> }
+
+: GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+{ GP2 -> <TRUE> }
+
+: GP3  <# 1 0 # # #> S" 01" S= ;
+{ GP3 -> <TRUE> }
+
+: GP4  <# 1 0 #S #> S" 1" S= ;
+{ GP4 -> <TRUE> }
+
+24 CONSTANT MAX-BASE            \ BASE 2 .. 36
+: COUNT-BITS
+   0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
+COUNT-BITS 2* CONSTANT #BITS-UD     \ NUMBER OF BITS IN UD
+
+: GP5
+   BASE @ <TRUE>
+   MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
+      I BASE !              \ TBD: ASSUMES BASE WORKS
+      I 0 <# #S #> S" 10" S= AND
+   LOOP
+   SWAP BASE ! ;
+{ GP5 -> <TRUE> }
+
+: GP6
+   BASE @ >R  2 BASE !
+   MAX-UINT MAX-UINT <# #S #>       \ MAXIMUM UD TO BINARY
+   R> BASE !                \ S: C-ADDR U
+   DUP #BITS-UD = SWAP
+   0 DO                 \ S: C-ADDR FLAG
+      OVER C@ [CHAR] 1 = AND        \ ALL ONES
+      >R CHAR+ R>
+   LOOP SWAP DROP ;
+{ GP6 -> <TRUE> }
+
+: GP7
+   BASE @ >R    MAX-BASE BASE !
+   <TRUE>
+   A 0 DO
+      I 0 <# #S #>
+      1 = SWAP C@ I 30 + = AND AND
+   LOOP
+   MAX-BASE A DO
+      I 0 <# #S #>
+      1 = SWAP C@ 41 I A - + = AND AND
+   LOOP
+   R> BASE ! ;
+
+{ GP7 -> <TRUE> }
+
+\ >NUMBER TESTS
+CREATE GN-BUF 0 C,
+: GN-STRING GN-BUF 1 ;
+: GN-CONSUMED   GN-BUF CHAR+ 0 ;
+: GN'       [CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
+
+{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
+{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
+{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
+{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE
+{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
+{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
+
+: >NUMBER-BASED
+   BASE @ >R BASE ! >NUMBER R> BASE ! ;
+
+{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
+{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
+{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
+{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
+
+: GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+   BASE @ >R BASE !
+   <# #S #>
+   0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
+   R> BASE ! ;
+{ 0 0 2 GN1 -> 0 0 0 }
+{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
+{ 0 0 MAX-BASE GN1 -> 0 0 0 }
+{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
+
+: GN2   \ ( -- 16 10 )
+   BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
+{ GN2 -> 10 A }
+
+\ ------------------------------------------------------------------------
+TESTING FILL MOVE
+
+CREATE FBUF 00 C, 00 C, 00 C,
+CREATE SBUF 12 C, 34 C, 56 C,
+: SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
+
+{ FBUF 0 20 FILL -> }
+{ SEEBUF -> 00 00 00 }
+
+{ FBUF 1 20 FILL -> }
+{ SEEBUF -> 20 00 00 }
+
+{ FBUF 3 20 FILL -> }
+{ SEEBUF -> 20 20 20 }
+
+{ FBUF FBUF 3 CHARS MOVE -> }       \ BIZARRE SPECIAL CASE
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 0 CHARS MOVE -> }
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 1 CHARS MOVE -> }
+{ SEEBUF -> 12 20 20 }
+
+{ SBUF FBUF 3 CHARS MOVE -> }
+{ SEEBUF -> 12 34 56 }
+
+{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }
+{ SEEBUF -> 12 12 34 }
+
+{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }
+{ SEEBUF -> 12 34 34 }
+
+\ ------------------------------------------------------------------------
+TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
+
+: OUTPUT-TEST
+   ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
+   41 BL DO I EMIT LOOP CR
+   61 41 DO I EMIT LOOP CR
+   7F 61 DO I EMIT LOOP CR
+   ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
+   9 1+ 0 DO I . LOOP CR
+   ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
+   [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
+   ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
+   [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
+   ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
+   5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
+   ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
+   S" LINE 1" TYPE CR S" LINE 2" TYPE CR
+   ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
+   ."   SIGNED: " MIN-INT . MAX-INT . CR
+   ." UNSIGNED: " 0 U. MAX-UINT U. CR
+;
+
+{ OUTPUT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING INPUT: ACCEPT
+
+CREATE ABUF 80 CHARS ALLOT
+
+: ACCEPT-TEST
+   CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
+   ABUF 80 ACCEPT
+   CR ." RECEIVED: " [CHAR] " EMIT
+   ABUF SWAP TYPE [CHAR] " EMIT CR
+;
+
+{ ACCEPT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING DICTIONARY SEARCH RULES
+
+{ : GDX   123 ; : GDX   GDX 234 ; -> }
+
+{ GDX -> 123 234 }
+
+

diff --git a/fth/filefind.fth b/fth/filefind.fth
index 1d97f84..ea57dec 100644 (file)
--- a/fth/filefind.fth
+++ b/fth/filefind.fth
@@ -1,119 +1,119 @@
-\ @(#) filefind.fth 98/01/26 1.2\r
-\ FILE?  ( <name> -- , report which file this Forth word was defined in )\r
-\\r
-\ FILE? looks for ::::Filename and ;;;; in the dictionary\r
-\ that have been left by INCLUDE.  It figures out nested\r
-\ includes and reports each file that defines the word.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1992 Phil Burk\r
-\\r
-\ 00001 PLB 2/21/92 Handle words from kernel or keyboard.\r
-\              Support EACH.FILE?\r
-\ 961213 PLB Port to pForth.\r
-\r
-ANEW TASK-FILEFIND.FTH\r
-\r
-: BE@ { addr | val -- val , fetch from unaligned address in BigEndian order }\r
-       4 0\r
-       DO\r
-               addr i + c@\r
-               val 8 lshift or -> val\r
-       LOOP\r
-       val\r
-;\r
-\r
-: BE! { val addr -- , store to unaligned address in BigEndian order }\r
-       4 0\r
-       DO\r
-           val 3 i - 8 * rshift\r
-               addr i + c!\r
-       LOOP\r
-;\r
-: BEW@ { addr -- , fetch word from unaligned address in BigEndian order }\r
-       addr c@ 8 lshift\r
-       addr 1+ c@ OR\r
-;\r
-\r
-: BEW! { val addr -- , store word to unaligned address in BigEndian order }\r
-       val 8 rshift addr c!\r
-       val addr 1+ c!\r
-;\r
-\r
-\ scan dictionary from NFA for filename\r
-: F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count }\r
-       0 -> dpth\r
-       0 -> stoploop\r
-       0 -> keyb\r
-       nfa -> nfa0\r
-       BEGIN\r
-               nfa prevname -> nfa\r
-               nfa 0>\r
-               IF\r
-                       nfa 1+ be@\r
-                       CASE\r
-                               $ 3a3a3a3a ( :::: )\r
-                               OF\r
-                                       dpth 0=\r
-                                       IF\r
-                                               nfa count 31 and\r
-                                               4 - swap 4 + swap\r
-                                               true -> stoploop\r
-                                       ELSE\r
-                                               -1 dpth + -> dpth\r
-                                       THEN\r
-                               ENDOF\r
-                               $ 3b3b3b3b ( ;;;; )\r
-                               OF\r
-                                               1 dpth + -> dpth\r
-                                               true -> keyb     \ maybe from keyboard\r
-                               ENDOF\r
-                       ENDCASE\r
-               ELSE\r
-                       true -> stoploop\r
-                       keyb\r
-                       IF\r
-                               " keyboard"\r
-                       ELSE\r
-                               " 'C' kernel"\r
-                       THEN\r
-                       count\r
-               THEN\r
-               stoploop\r
-       UNTIL\r
-;\r
-\r
-: FINDNFA.FROM { $name start_nfa -- nfa true | $word false }\r
-       context @ >r\r
-       start_nfa context !\r
-       $name findnfa\r
-       r> context !\r
-;\r
-\r
-\ Search entire dictionary for all occurences of named word.\r
-: FILE? {  | $word nfa done? -- , take name from input }\r
-       0 -> done?\r
-       bl word -> $word\r
-       $word findnfa\r
-       IF  ( -- nfa )\r
-               $word count type ."  from:" cr\r
-               -> nfa\r
-               BEGIN\r
-                       nfa f?.search.nfa ( addr cnt )\r
-                       nfa name> 12 .r   \ print xt\r
-                       4 spaces type cr\r
-                       nfa prevname dup -> nfa\r
-                       0>\r
-                       IF\r
-                               $word nfa findnfa.from  \ search from one behind found nfa\r
-                               swap -> nfa\r
-                               not\r
-                       ELSE\r
-                               true\r
-                       THEN\r
-               UNTIL\r
-       ELSE ( -- $word )\r
-               count type ."  not found!" cr\r
-       THEN\r
-;\r
-\r
+\ @(#) filefind.fth 98/01/26 1.2
+\ FILE?  ( <name> -- , report which file this Forth word was defined in )
+\
+\ FILE? looks for ::::Filename and ;;;; in the dictionary
+\ that have been left by INCLUDE.  It figures out nested
+\ includes and reports each file that defines the word.
+\
+\ Author: Phil Burk
+\ Copyright 1992 Phil Burk
+\
+\ 00001 PLB 2/21/92 Handle words from kernel or keyboard.
+\       Support EACH.FILE?
+\ 961213 PLB Port to pForth.
+
+ANEW TASK-FILEFIND.FTH
+
+: BE@ { addr | val -- val , fetch from unaligned address in BigEndian order }
+    4 0
+    DO
+        addr i + c@
+        val 8 lshift or -> val
+    LOOP
+    val
+;
+
+: BE! { val addr -- , store to unaligned address in BigEndian order }
+    4 0
+    DO
+        val 3 i - 8 * rshift
+        addr i + c!
+    LOOP
+;
+: BEW@ { addr -- , fetch word from unaligned address in BigEndian order }
+    addr c@ 8 lshift
+    addr 1+ c@ OR
+;
+
+: BEW! { val addr -- , store word to unaligned address in BigEndian order }
+    val 8 rshift addr c!
+    val addr 1+ c!
+;
+
+\ scan dictionary from NFA for filename
+: F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count }
+    0 -> dpth
+    0 -> stoploop
+    0 -> keyb
+    nfa -> nfa0
+    BEGIN
+        nfa prevname -> nfa
+        nfa 0>
+        IF
+            nfa 1+ be@
+            CASE
+                $ 3a3a3a3a ( :::: )
+                OF
+                    dpth 0=
+                    IF
+                        nfa count 31 and
+                        4 - swap 4 + swap
+                        true -> stoploop
+                    ELSE
+                        -1 dpth + -> dpth
+                    THEN
+                ENDOF
+                $ 3b3b3b3b ( ;;;; )
+                OF
+                        1 dpth + -> dpth
+                        true -> keyb     \ maybe from keyboard
+                ENDOF
+            ENDCASE
+        ELSE
+            true -> stoploop
+            keyb
+            IF
+                " keyboard"
+            ELSE
+                " 'C' kernel"
+            THEN
+            count
+        THEN
+        stoploop
+    UNTIL
+;
+
+: FINDNFA.FROM { $name start_nfa -- nfa true | $word false }
+    context @ >r
+    start_nfa context !
+    $name findnfa
+    r> context !
+;
+
+\ Search entire dictionary for all occurences of named word.
+: FILE? {  | $word nfa done? -- , take name from input }
+    0 -> done?
+    bl word -> $word
+    $word findnfa
+    IF  ( -- nfa )
+        $word count type ."  from:" cr
+        -> nfa
+        BEGIN
+            nfa f?.search.nfa ( addr cnt )
+            nfa name> 12 .r   \ print xt
+            4 spaces type cr
+            nfa prevname dup -> nfa
+            0>
+            IF
+                $word nfa findnfa.from  \ search from one behind found nfa
+                swap -> nfa
+                not
+            ELSE
+                true
+            THEN
+        UNTIL
+    ELSE ( -- $word )
+        count type ."  not found!" cr
+    THEN
+;
+

diff --git a/fth/floats.fth b/fth/floats.fth
index 02d1625..650730f 100644 (file)
--- a/fth/floats.fth
+++ b/fth/floats.fth
@@ -1,502 +1,502 @@
-\ @(#) floats.fth 98/02/26 1.4 17:51:40\r
-\ High Level Forth support for Floating Point\r
-\\r
-\ Author: Phil Burk and Darren Gibbs\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 19970702 PLB Drop 0.0 in REPRESENT to fix  0.0 F.\r
-\ 19980220 PLB Added FG. , fixed up large and small formatting\r
-\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix  0.0 F.  (!!!)\r
-\              Fixed F~ by using (F.EXACTLY)\r
-\r
-ANEW TASK-FLOATS.FTH\r
-\r
-: FALIGNED     ( addr -- a-addr )\r
-       1 floats 1- +\r
-       1 floats /\r
-       1 floats *\r
-;\r
-\r
-: FALIGN       ( -- , align DP )\r
-       dp @ faligned dp !\r
-;\r
-\r
-\ account for size of create when aligning floats\r
-here\r
-create fp-create-size\r
-fp-create-size swap - constant CREATE_SIZE\r
-\r
-: FALIGN.CREATE  ( -- , align DP for float after CREATE )\r
-       dp @\r
-       CREATE_SIZE +\r
-       faligned\r
-       CREATE_SIZE -\r
-       dp !\r
-;\r
-\r
-: FCREATE  ( <name> -- , create with float aligned data )\r
-       falign.create\r
-       CREATE\r
-;\r
-\r
-: FVARIABLE ( <name> -- ) ( F: -- )\r
-       FCREATE 1 floats allot\r
-;\r
-\r
-: FCONSTANT\r
-       FCREATE here   1 floats allot   f! \r
-       DOES> f@ \r
-;\r
-\r
-: F0SP ( -- ) ( F: ? -- )\r
-       fdepth 0 max  0 ?DO fdrop LOOP \r
-;\r
-\r
-\ Convert between single precision and floating point\r
-: S>F ( s -- ) ( F: -- r )\r
-       s>d d>f\r
-;\r
-: F>S ( -- s ) ( F: r -- )\r
-       f>d d>s\r
-;              \r
-\r
-: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }\r
-       1 floats -> fsize\r
-       fsize cell 1- + cell 1- invert and  \ round up to nearest multiple of stack size\r
-       cell / -> fcells ( number of cells per float )\r
-\ make room on data stack for floats data\r
-       fcells 0 ?DO 0 LOOP\r
-       sp@ -> caddr1\r
-       fcells 0 ?DO 0 LOOP\r
-       sp@ -> caddr2\r
-\ compare bit representation\r
-       caddr1 f!\r
-       caddr2 f!\r
-       caddr1 fsize caddr2 fsize compare 0= \r
-       >r fcells 2* 0 ?DO drop LOOP r>  \ drop float bits\r
-;\r
-\r
-: F~ ( -0- flag ) ( r1 r2 r3 -f- )\r
-       fdup F0<\r
-       IF\r
-               frot frot  ( -- r3 r1 r2 )\r
-               fover fover ( -- r3 r1 r2 r1 r2 )\r
-               f- fabs    ( -- r3 r1 r2 |r1-r2| )\r
-               frot frot  ( -- r3  |r1-r2| r1 r2 )\r
-               fabs fswap fabs f+ ( -- r3 |r1-r2|  |r1|+|r2| )\r
-               frot fabs f* ( -- |r1-r2|  |r1|+|r2|*|r3| )\r
-               f<\r
-       ELSE\r
-               fdup f0=\r
-               IF\r
-                       fdrop\r
-                       (f.exactly)  \ f- f0=  \ 19980812 Used to cheat. Now actually compares bit patterns.\r
-               ELSE\r
-                       frot frot  ( -- r3 r1 r2 )\r
-                       f- fabs    ( -- r3 |r1-r2| )\r
-                       fswap f<\r
-               THEN\r
-       THEN\r
-;\r
-\r
-\ FP Output --------------------------------------------------------\r
-fvariable FVAR-REP  \ scratch var for represent\r
-: REPRESENT { c-addr u | n flag1 flag2 --  n flag1 flag2 , FLOATING } ( F: r -- )\r
-       TRUE -> flag2   \ FIXME - need to check range\r
-       fvar-rep f!\r
-\\r
-       fvar-rep f@ f0<\r
-       IF\r
-               -1 -> flag1\r
-               fvar-rep f@ fabs fvar-rep f!   \ absolute value\r
-       ELSE\r
-               0 -> flag1\r
-       THEN\r
-\\r
-       fvar-rep f@ f0=\r
-       IF\r
-\              fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."\r
-               c-addr u [char] 0 fill\r
-               0 -> n\r
-       ELSE\r
-               fvar-rep f@ \r
-               flog\r
-               fdup f0< not\r
-               IF\r
-                       1 s>f f+ \ round up exponent\r
-               THEN\r
-               f>s -> n   \r
-\ ." REP - n = " n . cr\r
-\ normalize r to u digits\r
-               fvar-rep f@\r
-               10 s>f u n - s>f f** f*\r
-               1 s>f 2 s>f f/ f+   \ round result\r
-\\r
-\ convert float to double_int then convert to text\r
-               f>d\r
-\ ." REP - d = " over . dup . cr\r
-               <#  u 1- 0 ?DO # loop #s #>  \ ( -- addr cnt )\r
-\ Adjust exponent if rounding caused number of digits to increase.\r
-\ For example from 9999 to 10000.\r
-               u - +-> n  \r
-               c-addr u move\r
-       THEN\r
-\\r
-       n flag1 flag2\r
-;\r
-\r
-variable FP-PRECISION\r
-\r
-\ Set maximum digits that are meaningful for the precision that we use.\r
-1 FLOATS 4 / 7 * constant FP_PRECISION_MAX\r
-\r
-: PRECISION ( -- u )\r
-       fp-precision @\r
-;\r
-: SET-PRECISION ( u -- )\r
-       fp_precision_max min\r
-       fp-precision !\r
-;\r
-7 set-precision\r
-\r
-32 constant FP_REPRESENT_SIZE\r
-64 constant FP_OUTPUT_SIZE\r
-\r
-create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot  \ used with REPRESENT\r
-create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot     \ used to assemble final output\r
-variable FP-OUTPUT-PTR            \ points into FP-OUTPUT-PAD\r
-\r
-: FP.HOLD ( char -- , add char to output )\r
-       fp-output-ptr @ fp-output-pad 64 + <\r
-       IF\r
-               fp-output-ptr @ tuck c!\r
-               1+ fp-output-ptr !\r
-       ELSE\r
-               drop\r
-       THEN\r
-;\r
-: FP.APPEND { addr cnt -- , add string to output }\r
-       cnt 0 max   0\r
-       ?DO\r
-               addr i + c@ fp.hold\r
-       LOOP\r
-;\r
-\r
-: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )\r
-       BEGIN\r
-               fp-output-ptr @ fp-output-pad u>\r
-               fp-output-ptr @ 1- c@ [char] 0 =\r
-               and\r
-       WHILE\r
-               -1 fp-output-ptr +!\r
-       REPEAT\r
-;\r
-\r
-: FP.APPEND.ZEROS ( numZeros -- )\r
-       0 max   0\r
-       ?DO [char] 0 fp.hold\r
-       LOOP\r
-;\r
-\r
-: FP.MOVE.DECIMAL   { n prec -- , append with decimal point shifted }\r
-       fp-represent-pad n prec min fp.append\r
-       n prec - fp.append.zeros\r
-       [char] . fp.hold\r
-       fp-represent-pad n +\r
-       prec n - 0 max fp.append\r
-;\r
-\r
-: (EXP.) ( n -- addr cnt , convert exponent to two digit value )\r
-       dup abs 0\r
-       <# # #s\r
-       rot 0<\r
-       IF [char] - HOLD\r
-       ELSE [char] + hold\r
-       THEN\r
-       #>\r
-;\r
-\r
-: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )\r
-;\r
-\r
-: (FS.)  ( -- addr cnt ) ( F: r -- , scientific notation )\r
-       fp-output-pad fp-output-ptr !  \ setup pointer\r
-       fp-represent-pad   precision  represent\r
-\ ." (FS.) - represent " fp-represent-pad precision type cr\r
-       ( -- n flag1 flag2 )\r
-       IF\r
-               IF [char] - fp.hold\r
-               THEN\r
-               1 precision fp.move.decimal\r
-               [char] e fp.hold\r
-               1- (exp.) fp.append \ n\r
-       ELSE\r
-               2drop\r
-               s" <FP-OUT-OF-RANGE>" fp.append\r
-       THEN\r
-       fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FS.  ( F: r -- , scientific notation )\r
-       (fs.) type space\r
-;\r
-\r
-: (FE.)  ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }\r
-       fp-output-pad fp-output-ptr !  \ setup pointer\r
-       fp-represent-pad precision represent\r
-       ( -- n flag1 flag2 )\r
-       IF\r
-               IF [char] - fp.hold\r
-               THEN\r
-\ convert exponent to multiple of three\r
-               -> n\r
-               n 1- s>d 3 fm/mod \ use floored divide\r
-               3 * -> n3\r
-               1+ precision fp.move.decimal \ amount to move decimal point\r
-               [char] e fp.hold\r
-               n3 (exp.) fp.append \ n\r
-       ELSE\r
-               2drop\r
-               s" <FP-OUT-OF-RANGE>" fp.append\r
-       THEN\r
-       fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FE.  ( F: r -- , engineering notation )\r
-       (FE.) type space\r
-;\r
-\r
-: (FG.)  ( F: r -- , normal or scientific ) { | n n3 ndiff -- }\r
-       fp-output-pad fp-output-ptr !  \ setup pointer\r
-       fp-represent-pad precision represent\r
-       ( -- n flag1 flag2 )\r
-       IF\r
-               IF [char] - fp.hold\r
-               THEN\r
-\ compare n with precision to see whether we do scientific display\r
-               dup precision >\r
-               over -3 < OR\r
-               IF  \ use exponential notation\r
-                       1 precision fp.move.decimal\r
-                       fp.strip.trailing.zeros\r
-                       [char] e fp.hold\r
-                       1- (exp.) fp.append \ n\r
-               ELSE\r
-                       dup 0>\r
-                       IF\r
-\ POSITIVE EXPONENT - place decimal point in middle\r
-                               precision fp.move.decimal\r
-                       ELSE\r
-\ NEGATIVE EXPONENT - use 0.000????\r
-                               s" 0." fp.append\r
-\ output leading zeros\r
-                               negate fp.append.zeros\r
-                               fp-represent-pad precision fp.append\r
-                       THEN\r
-                       fp.strip.trailing.zeros\r
-               THEN\r
-       ELSE\r
-               2drop\r
-               s" <FP-OUT-OF-RANGE>" fp.append\r
-       THEN\r
-       fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FG.  ( F: r -- )\r
-       (fg.) type space\r
-;\r
-\r
-: (F.)  ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }\r
-       fp-output-pad fp-output-ptr !  \ setup pointer\r
-       fp-represent-pad  \ place to put number\r
-       fdup flog 1 s>f f+ f>s precision max\r
-       fp_precision_max min dup -> prec'\r
-       represent\r
-       ( -- n flag1 flag2 )\r
-       IF\r
-\ add '-' sign if negative\r
-               IF [char] - fp.hold\r
-               THEN\r
-\ compare n with precision to see whether we must do scientific display\r
-               dup fp_precision_max >\r
-               IF  \ use exponential notation\r
-                       1 precision fp.move.decimal\r
-                       fp.strip.trailing.zeros\r
-                       [char] e fp.hold\r
-                       1- (exp.) fp.append \ n\r
-               ELSE\r
-                       dup 0>\r
-                       IF\r
-       \ POSITIVE EXPONENT - place decimal point in middle\r
-                               prec' fp.move.decimal\r
-                       ELSE\r
-       \ NEGATIVE EXPONENT - use 0.000????\r
-                               s" 0." fp.append\r
-       \ output leading zeros\r
-                               dup negate precision min\r
-                               fp.append.zeros\r
-                               fp-represent-pad precision rot + fp.append\r
-                       THEN\r
-               THEN\r
-       ELSE\r
-               2drop\r
-               s" <FP-OUT-OF-RANGE>" fp.append\r
-       THEN\r
-       fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: F.  ( F: r -- )\r
-       (f.) type space\r
-;\r
-\r
-: F.S  ( -- , print FP stack )\r
-       ." FP> "\r
-       fdepth 0>\r
-       IF\r
-               fdepth 0\r
-               DO\r
-                       cr?\r
-                       fdepth i - 1-  \ index of next float\r
-                       fpick f. cr?\r
-               LOOP\r
-       ELSE\r
-               ." empty"\r
-       THEN\r
-       cr\r
-;\r
-\r
-\ FP Input ----------------------------------------------------------\r
-variable FP-REQUIRE-E   \ must we put an E in FP numbers?\r
-false fp-require-e !   \ violate ANSI !!\r
-\r
-: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }\r
-       u 0= IF false exit THEN\r
-       false -> flag\r
-       0 -> nshift\r
-\\r
-\ check for minus sign\r
-       c-addr c@ [char] - =     dup -> fsign\r
-       c-addr c@ [char] + = OR\r
-       IF   1 +-> c-addr   -1 +-> u   \ skip char\r
-       THEN\r
-\\r
-\ convert first set of digits\r
-       0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo\r
-       u' 0>\r
-       IF\r
-\ convert optional second set of digits\r
-               c-addr c@ [char] . =\r
-               IF\r
-                       dlo dhi c-addr 1+ u' 1- dup -> nshift >number\r
-                       dup nshift - -> nshift\r
-                       -> u' -> c-addr -> dhi -> dlo\r
-               THEN\r
-\ convert exponent\r
-               u' 0>\r
-               IF\r
-                       c-addr c@ [char] E =\r
-                       c-addr c@ [char] e =  OR\r
-                       IF\r
-                               1 +-> c-addr   -1 +-> u'   \ skip E char\r
-                               u' 0>\r
-                               IF\r
-                               c-addr c@ [char] + = \ ignore + on exponent\r
-                               IF\r
-                        1 +-> c-addr   -1 +-> u'   \ skip char\r
-                    THEN\r
-                                   c-addr u' ((number?))\r
-                                   num_type_single =\r
-                                   IF\r
-                                          nshift + -> nshift\r
-                                          true -> flag\r
-                                   THEN\r
-                               ELSE\r
-                                   true -> flag   \ allow "1E"\r
-                               THEN\r
-                       THEN\r
-               ELSE\r
-\ only require E field if this variable is true\r
-                       fp-require-e @ not -> flag\r
-               THEN\r
-       THEN\r
-\ convert double precision int to float\r
-       flag\r
-       IF\r
-               dlo dhi d>f\r
-               10 s>f nshift s>f f** f*   \ apply exponent\r
-               fsign\r
-               IF\r
-                       fnegate\r
-               THEN\r
-       THEN\r
-       flag\r
-;\r
-\r
-3 constant NUM_TYPE_FLOAT   \ possible return type for NUMBER?\r
-\r
-: (FP.NUMBER?)   ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )\r
-\ check to see if it is a valid float, if not use old (NUMBER?)\r
-       dup count >float\r
-       IF\r
-               drop NUM_TYPE_FLOAT\r
-       ELSE\r
-               (number?)\r
-       THEN\r
-;\r
-\r
-defer fp.old.number?\r
-variable FP-IF-INIT\r
-\r
-: FP.TERM    ( -- , deinstall fp conversion )\r
-       fp-if-init @\r
-       IF\r
-               what's  fp.old.number? is number?\r
-               fp-if-init off\r
-       THEN\r
-;\r
-\r
-: FP.INIT  ( -- , install FP converion )\r
-       fp.term\r
-       what's number? is fp.old.number?\r
-       ['] (fp.number?) is number?\r
-       fp-if-init on\r
-       ." Floating point numeric conversion installed." cr\r
-;\r
-\r
-FP.INIT\r
-if.forgotten fp.term\r
-\r
-\r
-0 [IF]\r
-\r
-23.8e-9 fconstant fsmall\r
-1.0 fsmall f- fconstant falmost1\r
-." Should be 1.0 = " falmost1 f. cr\r
-\r
-: TSEGF  ( r -f- , print in all formats )\r
-." --------------------------------" cr\r
-       34 0\r
-       DO\r
-               fdup fs. 4 spaces  fdup fe. 4 spaces\r
-               fdup fg. 4 spaces  fdup f.  cr\r
-               10.0 f/\r
-       LOOP\r
-       fdrop\r
-;\r
-\r
-: TFP\r
-       1.234e+22 tsegf\r
-       1.23456789e+22 tsegf\r
-       0.927 fsin 1.234e+22 f* tsegf\r
-;\r
-\r
-[THEN]\r
+\ @(#) floats.fth 98/02/26 1.4 17:51:40
+\ High Level Forth support for Floating Point
+\
+\ Author: Phil Burk and Darren Gibbs
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ 19970702 PLB Drop 0.0 in REPRESENT to fix  0.0 F.
+\ 19980220 PLB Added FG. , fixed up large and small formatting
+\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix  0.0 F.  (!!!)
+\              Fixed F~ by using (F.EXACTLY)
+
+ANEW TASK-FLOATS.FTH
+
+: FALIGNED  ( addr -- a-addr )
+    1 floats 1- +
+    1 floats /
+    1 floats *
+;
+
+: FALIGN    ( -- , align DP )
+    dp @ faligned dp !
+;
+
+\ account for size of create when aligning floats
+here
+create fp-create-size
+fp-create-size swap - constant CREATE_SIZE
+
+: FALIGN.CREATE  ( -- , align DP for float after CREATE )
+    dp @
+    CREATE_SIZE +
+    faligned
+    CREATE_SIZE -
+    dp !
+;
+
+: FCREATE  ( <name> -- , create with float aligned data )
+    falign.create
+    CREATE
+;
+
+: FVARIABLE ( <name> -- ) ( F: -- )
+    FCREATE 1 floats allot
+;
+
+: FCONSTANT
+    FCREATE here   1 floats allot   f!
+    DOES> f@
+;
+
+: F0SP ( -- ) ( F: ? -- )
+    fdepth 0 max  0 ?DO fdrop LOOP
+;
+
+\ Convert between single precision and floating point
+: S>F ( s -- ) ( F: -- r )
+    s>d d>f
+;
+: F>S ( -- s ) ( F: r -- )
+    f>d d>s
+;
+
+: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }
+    1 floats -> fsize
+    fsize cell 1- + cell 1- invert and  \ round up to nearest multiple of stack size
+    cell / -> fcells ( number of cells per float )
+\ make room on data stack for floats data
+    fcells 0 ?DO 0 LOOP
+    sp@ -> caddr1
+    fcells 0 ?DO 0 LOOP
+    sp@ -> caddr2
+\ compare bit representation
+    caddr1 f!
+    caddr2 f!
+    caddr1 fsize caddr2 fsize compare 0=
+    >r fcells 2* 0 ?DO drop LOOP r>  \ drop float bits
+;
+
+: F~ ( -0- flag ) ( r1 r2 r3 -f- )
+    fdup F0<
+    IF
+        frot frot  ( -- r3 r1 r2 )
+        fover fover ( -- r3 r1 r2 r1 r2 )
+        f- fabs    ( -- r3 r1 r2 |r1-r2| )
+        frot frot  ( -- r3  |r1-r2| r1 r2 )
+        fabs fswap fabs f+ ( -- r3 |r1-r2|  |r1|+|r2| )
+        frot fabs f* ( -- |r1-r2|  |r1|+|r2|*|r3| )
+        f<
+    ELSE
+        fdup f0=
+        IF
+            fdrop
+            (f.exactly)  \ f- f0=  \ 19980812 Used to cheat. Now actually compares bit patterns.
+        ELSE
+            frot frot  ( -- r3 r1 r2 )
+            f- fabs    ( -- r3 |r1-r2| )
+            fswap f<
+        THEN
+    THEN
+;
+
+\ FP Output --------------------------------------------------------
+fvariable FVAR-REP  \ scratch var for represent
+: REPRESENT { c-addr u | n flag1 flag2 --  n flag1 flag2 , FLOATING } ( F: r -- )
+    TRUE -> flag2   \ FIXME - need to check range
+    fvar-rep f!
+\
+    fvar-rep f@ f0<
+    IF
+        -1 -> flag1
+        fvar-rep f@ fabs fvar-rep f!   \ absolute value
+    ELSE
+        0 -> flag1
+    THEN
+\
+    fvar-rep f@ f0=
+    IF
+\       fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."
+        c-addr u [char] 0 fill
+        0 -> n
+    ELSE
+        fvar-rep f@
+        flog
+        fdup f0< not
+        IF
+            1 s>f f+ \ round up exponent
+        THEN
+        f>s -> n
+\ ." REP - n = " n . cr
+\ normalize r to u digits
+        fvar-rep f@
+        10 s>f u n - s>f f** f*
+        1 s>f 2 s>f f/ f+   \ round result
+\
+\ convert float to double_int then convert to text
+        f>d
+\ ." REP - d = " over . dup . cr
+        <#  u 1- 0 ?DO # loop #s #>  \ ( -- addr cnt )
+\ Adjust exponent if rounding caused number of digits to increase.
+\ For example from 9999 to 10000.
+        u - +-> n
+        c-addr u move
+    THEN
+\
+    n flag1 flag2
+;
+
+variable FP-PRECISION
+
+\ Set maximum digits that are meaningful for the precision that we use.
+1 FLOATS 4 / 7 * constant FP_PRECISION_MAX
+
+: PRECISION ( -- u )
+    fp-precision @
+;
+: SET-PRECISION ( u -- )
+    fp_precision_max min
+    fp-precision !
+;
+7 set-precision
+
+32 constant FP_REPRESENT_SIZE
+64 constant FP_OUTPUT_SIZE
+
+create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot  \ used with REPRESENT
+create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot     \ used to assemble final output
+variable FP-OUTPUT-PTR            \ points into FP-OUTPUT-PAD
+
+: FP.HOLD ( char -- , add char to output )
+    fp-output-ptr @ fp-output-pad 64 + <
+    IF
+        fp-output-ptr @ tuck c!
+        1+ fp-output-ptr !
+    ELSE
+        drop
+    THEN
+;
+: FP.APPEND { addr cnt -- , add string to output }
+    cnt 0 max   0
+    ?DO
+        addr i + c@ fp.hold
+    LOOP
+;
+
+: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )
+    BEGIN
+        fp-output-ptr @ fp-output-pad u>
+        fp-output-ptr @ 1- c@ [char] 0 =
+        and
+    WHILE
+        -1 fp-output-ptr +!
+    REPEAT
+;
+
+: FP.APPEND.ZEROS ( numZeros -- )
+    0 max   0
+    ?DO [char] 0 fp.hold
+    LOOP
+;
+
+: FP.MOVE.DECIMAL   { n prec -- , append with decimal point shifted }
+    fp-represent-pad n prec min fp.append
+    n prec - fp.append.zeros
+    [char] . fp.hold
+    fp-represent-pad n +
+    prec n - 0 max fp.append
+;
+
+: (EXP.) ( n -- addr cnt , convert exponent to two digit value )
+    dup abs 0
+    <# # #s
+    rot 0<
+    IF [char] - HOLD
+    ELSE [char] + hold
+    THEN
+    #>
+;
+
+: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )
+;
+
+: (FS.)  ( -- addr cnt ) ( F: r -- , scientific notation )
+    fp-output-pad fp-output-ptr !  \ setup pointer
+    fp-represent-pad   precision  represent
+\ ." (FS.) - represent " fp-represent-pad precision type cr
+    ( -- n flag1 flag2 )
+    IF
+        IF [char] - fp.hold
+        THEN
+        1 precision fp.move.decimal
+        [char] e fp.hold
+        1- (exp.) fp.append \ n
+    ELSE
+        2drop
+        s" <FP-OUT-OF-RANGE>" fp.append
+    THEN
+    fp-output-pad fp-output-ptr @ over -
+;
+
+: FS.  ( F: r -- , scientific notation )
+    (fs.) type space
+;
+
+: (FE.)  ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }
+    fp-output-pad fp-output-ptr !  \ setup pointer
+    fp-represent-pad precision represent
+    ( -- n flag1 flag2 )
+    IF
+        IF [char] - fp.hold
+        THEN
+\ convert exponent to multiple of three
+        -> n
+        n 1- s>d 3 fm/mod \ use floored divide
+        3 * -> n3
+        1+ precision fp.move.decimal \ amount to move decimal point
+        [char] e fp.hold
+        n3 (exp.) fp.append \ n
+    ELSE
+        2drop
+        s" <FP-OUT-OF-RANGE>" fp.append
+    THEN
+    fp-output-pad fp-output-ptr @ over -
+;
+
+: FE.  ( F: r -- , engineering notation )
+    (FE.) type space
+;
+
+: (FG.)  ( F: r -- , normal or scientific ) { | n n3 ndiff -- }
+    fp-output-pad fp-output-ptr !  \ setup pointer
+    fp-represent-pad precision represent
+    ( -- n flag1 flag2 )
+    IF
+        IF [char] - fp.hold
+        THEN
+\ compare n with precision to see whether we do scientific display
+        dup precision >
+        over -3 < OR
+        IF  \ use exponential notation
+            1 precision fp.move.decimal
+            fp.strip.trailing.zeros
+            [char] e fp.hold
+            1- (exp.) fp.append \ n
+        ELSE
+            dup 0>
+            IF
+\ POSITIVE EXPONENT - place decimal point in middle
+                precision fp.move.decimal
+            ELSE
+\ NEGATIVE EXPONENT - use 0.000????
+                s" 0." fp.append
+\ output leading zeros
+                negate fp.append.zeros
+                fp-represent-pad precision fp.append
+            THEN
+            fp.strip.trailing.zeros
+        THEN
+    ELSE
+        2drop
+        s" <FP-OUT-OF-RANGE>" fp.append
+    THEN
+    fp-output-pad fp-output-ptr @ over -
+;
+
+: FG.  ( F: r -- )
+    (fg.) type space
+;
+
+: (F.)  ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }
+    fp-output-pad fp-output-ptr !  \ setup pointer
+    fp-represent-pad  \ place to put number
+    fdup flog 1 s>f f+ f>s precision max
+    fp_precision_max min dup -> prec'
+    represent
+    ( -- n flag1 flag2 )
+    IF
+\ add '-' sign if negative
+        IF [char] - fp.hold
+        THEN
+\ compare n with precision to see whether we must do scientific display
+        dup fp_precision_max >
+        IF  \ use exponential notation
+            1 precision fp.move.decimal
+            fp.strip.trailing.zeros
+            [char] e fp.hold
+            1- (exp.) fp.append \ n
+        ELSE
+            dup 0>
+            IF
+    \ POSITIVE EXPONENT - place decimal point in middle
+                prec' fp.move.decimal
+            ELSE
+    \ NEGATIVE EXPONENT - use 0.000????
+                s" 0." fp.append
+    \ output leading zeros
+                dup negate precision min
+                fp.append.zeros
+                fp-represent-pad precision rot + fp.append
+            THEN
+        THEN
+    ELSE
+        2drop
+        s" <FP-OUT-OF-RANGE>" fp.append
+    THEN
+    fp-output-pad fp-output-ptr @ over -
+;
+
+: F.  ( F: r -- )
+    (f.) type space
+;
+
+: F.S  ( -- , print FP stack )
+    ." FP> "
+    fdepth 0>
+    IF
+        fdepth 0
+        DO
+            cr?
+            fdepth i - 1-  \ index of next float
+            fpick f. cr?
+        LOOP
+    ELSE
+        ." empty"
+    THEN
+    cr
+;
+
+\ FP Input ----------------------------------------------------------
+variable FP-REQUIRE-E   \ must we put an E in FP numbers?
+false fp-require-e !   \ violate ANSI !!
+
+: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }
+    u 0= IF false exit THEN
+    false -> flag
+    0 -> nshift
+\
+\ check for minus sign
+    c-addr c@ [char] - =     dup -> fsign
+    c-addr c@ [char] + = OR
+    IF   1 +-> c-addr   -1 +-> u   \ skip char
+    THEN
+\
+\ convert first set of digits
+    0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo
+    u' 0>
+    IF
+\ convert optional second set of digits
+        c-addr c@ [char] . =
+        IF
+            dlo dhi c-addr 1+ u' 1- dup -> nshift >number
+            dup nshift - -> nshift
+            -> u' -> c-addr -> dhi -> dlo
+        THEN
+\ convert exponent
+        u' 0>
+        IF
+            c-addr c@ [char] E =
+            c-addr c@ [char] e =  OR
+            IF
+                1 +-> c-addr   -1 +-> u'   \ skip E char
+                u' 0>
+                IF
+                    c-addr c@ [char] + = \ ignore + on exponent
+                    IF
+                        1 +-> c-addr   -1 +-> u'   \ skip char
+                    THEN
+                    c-addr u' ((number?))
+                    num_type_single =
+                    IF
+                       nshift + -> nshift
+                       true -> flag
+                    THEN
+                ELSE
+                    true -> flag   \ allow "1E"
+                THEN
+            THEN
+        ELSE
+\ only require E field if this variable is true
+            fp-require-e @ not -> flag
+        THEN
+    THEN
+\ convert double precision int to float
+    flag
+    IF
+        dlo dhi d>f
+        10 s>f nshift s>f f** f*   \ apply exponent
+        fsign
+        IF
+            fnegate
+        THEN
+    THEN
+    flag
+;
+
+3 constant NUM_TYPE_FLOAT   \ possible return type for NUMBER?
+
+: (FP.NUMBER?)   ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )
+\ check to see if it is a valid float, if not use old (NUMBER?)
+    dup count >float
+    IF
+        drop NUM_TYPE_FLOAT
+    ELSE
+        (number?)
+    THEN
+;
+
+defer fp.old.number?
+variable FP-IF-INIT
+
+: FP.TERM    ( -- , deinstall fp conversion )
+    fp-if-init @
+    IF
+        what's  fp.old.number? is number?
+        fp-if-init off
+    THEN
+;
+
+: FP.INIT  ( -- , install FP converion )
+    fp.term
+    what's number? is fp.old.number?
+    ['] (fp.number?) is number?
+    fp-if-init on
+    ." Floating point numeric conversion installed." cr
+;
+
+FP.INIT
+if.forgotten fp.term
+
+
+0 [IF]
+
+23.8e-9 fconstant fsmall
+1.0 fsmall f- fconstant falmost1
+." Should be 1.0 = " falmost1 f. cr
+
+: TSEGF  ( r -f- , print in all formats )
+." --------------------------------" cr
+    34 0
+    DO
+        fdup fs. 4 spaces  fdup fe. 4 spaces
+        fdup fg. 4 spaces  fdup f.  cr
+        10.0 f/
+    LOOP
+    fdrop
+;
+
+: TFP
+    1.234e+22 tsegf
+    1.23456789e+22 tsegf
+    0.927 fsin 1.234e+22 f* tsegf
+;
+
+[THEN]

diff --git a/fth/forget.fth b/fth/forget.fth
index 9dfd800..3971100 100644 (file)
--- a/fth/forget.fth
+++ b/fth/forget.fth
@@ -1,97 +1,97 @@
-\ @(#) forget.fth 98/01/26 1.2\r
-\ forget.fth\r
-\\r
-\ forget part of dictionary\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 19970701 PLB Use unsigned compares for machines with "negative" addresses.\r
-\r
-variable RFENCE    \ relocatable value below which we won't forget\r
-\r
-: FREEZE  ( -- , protect below here )\r
-       here rfence a!\r
-;\r
-\r
-: FORGET.NFA  ( nfa -- , set DP etc. )\r
-       dup name> >code dp !\r
-       prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !\r
-;\r
-\r
-: VERIFY.FORGET  ( nfa -- , ask for verification if below fence )\r
-       dup name> >code rfence a@ u<  \ 19970701\r
-       IF\r
-               >newline dup id. ."  is below fence!!" cr\r
-               drop\r
-       ELSE forget.nfa\r
-       THEN\r
-;\r
-\r
-: (FORGET)  ( <name> -- )\r
-       BL word findnfa\r
-       IF      verify.forget\r
-       ELSE ." FORGET - couldn't find " count type cr abort\r
-       THEN\r
-;\r
-\r
-variable LAST-FORGET   \ contains address of last if.forgotten frame\r
-0 last-forget !\r
-\r
-: IF.FORGOTTEN  ( <name> -- , place links in dictionary without header )\r
-       bl word find\r
-       IF      ( xt )\r
-               here                \ start of frame\r
-               last-forget a@ a,   \ Cell[0] = rel address of previous frame\r
-               last-forget a!      \ point to this frame\r
-               compile,            \ Cell[1] = xt for this frame\r
-       ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort\r
-       THEN\r
-;\r
-if.forgotten noop\r
-\r
-: [FORGET]  ( <name> -- , forget then exec forgotten words )\r
-       (forget)\r
-       last-forget\r
-       BEGIN a@ dup 0<>   \ 19970701\r
-               IF dup here u>   \ 19970701\r
-                       IF dup cell+ x@ execute false\r
-                       ELSE dup last-forget a! true\r
-                       THEN\r
-               ELSE true\r
-               THEN\r
-       UNTIL drop\r
-;\r
-\r
-: FORGET ( <name> -- , execute latest [FORGET] )\r
-       " [FORGET]" find\r
-       IF  execute\r
-       ELSE ." FORGET - couldn't find " count type cr abort\r
-       THEN\r
-;\r
-\r
-: ANEW ( -- , forget if defined then redefine )\r
-       >in @\r
-       bl word find\r
-       IF over >in ! forget\r
-       THEN drop\r
-       >in ! variable\r
-;\r
-\r
-: MARKER  ( <name> -- , define a word that forgets itself when executed, ANS )\r
-       CREATE\r
-               latest namebase -  \ convert to relocatable\r
-               ,                  \ save for DOES>\r
-       DOES>  ( -- body )\r
-               @ namebase +       \ convert back to NFA\r
-               verify.forget\r
-;\r
+\ @(#) forget.fth 98/01/26 1.2
+\ forget.fth
+\
+\ forget part of dictionary
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
+
+variable RFENCE    \ relocatable value below which we won't forget
+
+: FREEZE  ( -- , protect below here )
+    here rfence a!
+;
+
+: FORGET.NFA  ( nfa -- , set DP etc. )
+    dup name> >code dp !
+    prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
+;
+
+: VERIFY.FORGET  ( nfa -- , ask for verification if below fence )
+    dup name> >code rfence a@ u<  \ 19970701
+    IF
+        >newline dup id. ."  is below fence!!" cr
+        drop
+    ELSE forget.nfa
+    THEN
+;
+
+: (FORGET)  ( <name> -- )
+    BL word findnfa
+    IF  verify.forget
+    ELSE ." FORGET - couldn't find " count type cr abort
+    THEN
+;
+
+variable LAST-FORGET   \ contains address of last if.forgotten frame
+0 last-forget !
+
+: IF.FORGOTTEN  ( <name> -- , place links in dictionary without header )
+    bl word find
+    IF  ( xt )
+        here                \ start of frame
+        last-forget a@ a,   \ Cell[0] = rel address of previous frame
+        last-forget a!      \ point to this frame
+        compile,            \ Cell[1] = xt for this frame
+    ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
+    THEN
+;
+if.forgotten noop
+
+: [FORGET]  ( <name> -- , forget then exec forgotten words )
+    (forget)
+    last-forget
+    BEGIN a@ dup 0<>   \ 19970701
+        IF dup here u>   \ 19970701
+            IF dup cell+ x@ execute false
+            ELSE dup last-forget a! true
+            THEN
+        ELSE true
+        THEN
+    UNTIL drop
+;
+
+: FORGET ( <name> -- , execute latest [FORGET] )
+    " [FORGET]" find
+    IF  execute
+    ELSE ." FORGET - couldn't find " count type cr abort
+    THEN
+;
+
+: ANEW ( -- , forget if defined then redefine )
+    >in @
+    bl word find
+    IF over >in ! forget
+    THEN drop
+    >in ! variable
+;
+
+: MARKER  ( <name> -- , define a word that forgets itself when executed, ANS )
+    CREATE
+        latest namebase -  \ convert to relocatable
+        ,                  \ save for DOES>
+    DOES>  ( -- body )
+        @ namebase +       \ convert back to NFA
+        verify.forget
+;

diff --git a/fth/history.fth b/fth/history.fth
index 6299d1d..a61caaa 100644 (file)
--- a/fth/history.fth
+++ b/fth/history.fth
@@ -1,513 +1,513 @@
-\ Command Line History\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1988 Phil Burk\r
-\ Revised 2001 for pForth\r
-\r
-0 [IF]\r
-\r
-Requires an ANSI compatible terminal.\r
-\r
-To get Windows computers to use ANSI mode in their DOS windows,\r
-Add this line to "C:\CONFIG.SYS" then reboot.\r
-  \r
-  device=c:\windows\command\ansi.sys\r
-\r
-When command line history is on, you can use the UP and DOWN arrow to scroll\r
-through previous commands. Use the LEFT and RIGHT arrows to edit within a line.\r
-   CONTROL-A moves to beginning of line.\r
-   CONTROL-E moves to end of line.\r
-   CONTROL-X erases entire line.\r
-\r
-\r
-HISTORY#       ( -- , dump history buffer with numbers)\r
-HISTORY        ( -- , dump history buffer )\r
-XX             ( line# -- , execute line x of history )\r
-HISTORY.RESET  ( -- , clear history tables )\r
-HISTORY.ON     ( -- , install history vectors )\r
-HISTORY.OFF    ( -- , uninstall history vectors )\r
-\r
-[THEN]\r
-\r
-include? ESC[ termio.fth\r
-\r
-ANEW TASK-HISTORY.FTH\r
-decimal\r
-\r
-private{\r
-\r
-\ You can expand the history buffer by increasing this constant!!!!!!!!!!\r
-2048 constant KH_HISTORY_SIZE\r
-\r
-create KH-HISTORY kh_history_size allot\r
-KH-HISTORY kh_history_size erase\r
-\r
-\ An entry in the history buffer consists of\r
-\   byte  - Count byte = N,\r
-\   chars - N chars,\r
-\   short -  line number in Big Endian format,\r
-\   byte  - another Count byte = N, for reverse scan\r
-\\r
-\ The most recent entry is put at the beginning,\r
-\ older entries are shifted up.\r
-\r
-4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 size bytes )\r
-\r
-: KH-END ( -- addr , end of history buffer )\r
-       kh-history kh_history_size +\r
-;\r
-\r
-: LINENUM@ ( addr -- w , stores in BigEndian format )\r
-       dup c@ 8 shift\r
-       swap 1+ c@ or\r
-;\r
-\r
-: LINENUM! ( w addr -- )\r
-       over -8 shift over c!\r
-       1+ c!\r
-;\r
-\r
-variable KH-LOOK      ( cursor offset into history, point to 1st count byte of line )\r
-variable KH-MAX\r
-variable KH-COUNTER       ( 16 bit counter for line # )\r
-variable KH-SPAN          ( total number of characters in line )\r
-variable KH-MATCH-SPAN    ( span for matching on shift-up )\r
-variable KH-CURSOR        ( points to next insertion point )\r
-variable KH-ADDRESS       ( address to store chars )\r
-variable KH-INSIDE        ( true if we are scrolling inside the history buffer )\r
-\r
-: KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)\r
-       >r  ( save N )\r
-       kh-history dup r@ + ( source dest )\r
-       kh_history_size r> - 0 max move\r
-;\r
-\r
-: KH.NEWEST.LINE  ( -- addr count , most recent line )\r
-       kh-history count\r
-;\r
-\r
-: KH.REWIND ( -- , move cursor to most recent line )\r
-       0 kh-look !\r
-;\r
-\r
-: KH.CURRENT.ADDR ( -- $addr , count byte of current line )\r
-       kh-look @ kh-history +\r
-;\r
-\r
-: KH.CURRENT.LINE ( -- addr count )\r
-       kh.current.addr count\r
-;\r
-\r
-: KH.COMPARE ( addr count -- flag , true if redundant )\r
-       kh.newest.line compare 0=   \ note: ANSI COMPARE is different than JForth days\r
-;\r
-\r
-: KH.NUM.ADDR ( -- addr , address of current line's line count )\r
-       kh.current.line +\r
-;\r
-\r
-: KH.CURRENT.NUM ( -- # , number of current line )\r
-       kh.num.addr LINENUM@\r
-;\r
-\r
-: KH.ADDR++  ( $addr -- $addr' , convert one kh to previous )\r
-       count + 3 +\r
-;\r
-: KH.ADDR--  ( $addr -- $addr' , convert one kh to next )\r
-       dup 1- c@   \ get next lines endcount\r
-       4 +      \ account for lineNum and two count bytes\r
-       -       \ calc previous address\r
-;\r
-\r
-: KH.ENDCOUNT.ADDR ( -- addr , address of current end count )\r
-       kh.num.addr 2+\r
-;\r
-\r
-: KH.ADD.LINE ( addr count -- )\r
-       dup 256 >\r
-       IF ." KH.ADD.LINE - Too big for history!" 2drop\r
-       ELSE   ( add to end )\r
-\ Compare with most recent line.\r
-               2dup kh.compare\r
-               IF 2drop\r
-               ELSE\r
-                       >r ( save count )\r
-\ Set look pointer to point to first count byte of last string.\r
-                       0 kh-look !\r
-\ Make room for this line of text and line header. \r
-\ PLB20100823 Was cell+ which broke on 64-bit code.\r
-                       r@ KH_LINE_EXTRA_SIZE + kh.make.room\r
-\ Set count bytes at beginning and end.\r
-                       r@ kh-history c!  ( start count )\r
-                       r@ kh.endcount.addr c!\r
-                       kh-counter @ kh.num.addr LINENUM!  ( line )\r
-\ Number lines modulo 1024\r
-                       kh-counter @ 1+ $ 3FF and kh-counter !\r
-                       kh-history 1+   ( calc destination )\r
-                       r> cmove  ( copy chars into space )\r
-               THEN\r
-       THEN\r
-;\r
-\r
-: KH.BACKUP.LINE  { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds }\r
-       true -> cantmove ( default flag, at end of history )\r
-\ KH-LOOK points to count at start of current line\r
-       kh.current.addr c@       \ do we have any lines?\r
-       IF\r
-               kh.current.addr kh.addr++ -> addr'\r
-               addr' kh-end U<      \ within bounds?\r
-               IF  \r
-                       addr' c@     \ older line has chars?\r
-                       IF\r
-                               addr' kh-history - kh-look !\r
-                               false -> cantmove\r
-                       THEN\r
-               THEN\r
-       THEN\r
-       cantmove\r
-;\r
-\r
-: KH.FORWARD.LINE ( -- cantmove? )\r
-    kh-look @ 0= dup not\r
-    IF  kh.current.addr kh.addr--\r
-       kh-history - kh-look !\r
-    THEN\r
-;\r
-\r
-: KH.OLDEST.LINE   ( -- addr count | 0, oldest in buffer )\r
-    BEGIN kh.backup.line\r
-    UNTIL\r
-    kh.current.line dup 0=\r
-    IF\r
-       nip\r
-    THEN\r
-;\r
-\r
-: KH.FIND.LINE ( line# -- $addr )\r
-       kh.rewind\r
-    BEGIN kh.current.num over -\r
-    WHILE kh.backup.line\r
-        IF ." Line not in History Buffer!" cr drop 0 exit\r
-        THEN\r
-    REPEAT\r
-    drop kh.current.addr\r
-;\r
-\r
-\r
-: KH-BUFFER ( -- buffer )\r
-    kh-address @\r
-;\r
-\r
-: KH.RETURN ( -- , move to beginning of line )\r
-    0 out !\r
-    13 emit\r
-;\r
-\r
-: KH.REPLACE.LINE  ( addr count -- , make this the current line of input )\r
-    kh.return\r
-    tio.erase.eol\r
-    dup kh-span !\r
-    dup kh-cursor !\r
-    2dup kh-buffer swap cmove\r
-    type\r
-;\r
-\r
-: KH.GET.MATCH ( -- , search for line with same start )\r
-    kh-match-span @ 0=  ( keep length for multiple matches )\r
-    IF kh-span @ kh-match-span !\r
-    THEN\r
-    BEGIN\r
-       kh.backup.line not\r
-    WHILE\r
-       kh.current.line drop\r
-       kh-buffer kh-match-span @ text=\r
-        IF kh.current.line kh.replace.line\r
-           exit\r
-        THEN\r
-    REPEAT\r
-;\r
-\r
-: KH.FAR.RIGHT\r
-    kh-span @ kh-cursor @ - dup 0>\r
-    IF\r
-       tio.forwards\r
-        kh-span @ kh-cursor !\r
-    ELSE drop\r
-    THEN\r
-;\r
-\r
-: KH.FAR.LEFT ( -- )\r
-    kh.return\r
-    kh-cursor off\r
-;\r
-\r
-: KH.GET.OLDER ( -- , goto previous line )\r
-       kh-inside @\r
-       IF kh.backup.line drop\r
-       THEN\r
-       kh.current.line kh.replace.line\r
-       kh-inside on\r
-;\r
-\r
-: KH.GET.NEWER ( -- , next line )\r
-       kh.forward.line\r
-       IF\r
-               kh-inside off\r
-               tib 0\r
-       ELSE  kh.current.line\r
-       THEN\r
-       kh.replace.line\r
-;\r
-\r
-: KH.CLEAR.LINE ( -- , rewind history scrolling and clear line )\r
-       kh.rewind\r
-       tib 0 kh.replace.line\r
-       kh-inside off\r
-;\r
-\r
-: KH.GO.RIGHT  ( -- )\r
-    kh-cursor @ kh-span @ <\r
-    IF 1 kh-cursor +!\r
-       1 tio.forwards\r
-    THEN\r
-;\r
-\r
-: KH.GO.LEFT ( -- )\r
-    kh-cursor @ ?dup\r
-    IF 1- kh-cursor !\r
-       1 tio.backwards\r
-    THEN\r
-;\r
-\r
-: KH.REFRESH  ( -- , redraw current line as is )\r
-       kh.return\r
-       kh-buffer kh-span @ type\r
-       tio.erase.eol\r
-       \r
-       kh.return\r
-       kh-cursor @ ?dup \r
-       IF tio.forwards\r
-       THEN\r
-       \r
-       kh-span @ out !\r
-;\r
-\r
-: KH.BACKSPACE ( -- , backspace character from buffer and screen )\r
-    kh-cursor @ ?dup  ( past 0? )\r
-    IF  kh-span @ <\r
-        IF  ( inside line )\r
-            kh-buffer kh-cursor @ +  ( -- source )\r
-            dup 1- ( -- source dest )\r
-            kh-span @ kh-cursor @ - cmove\r
-\            ." Deleted!" cr \r
-        ELSE\r
-            backspace\r
-        THEN\r
-        -1 kh-span +!\r
-        -1 kh-cursor +!\r
-    ELSE bell\r
-    THEN\r
-    kh.refresh\r
-;\r
-\r
-: KH.DELETE ( -- , forward delete )\r
-    kh-cursor @ kh-span @ <  ( before end )\r
-    IF  ( inside line )\r
-        kh-buffer kh-cursor @ + 1+ ( -- source )\r
-        dup 1- ( -- source dest )\r
-        kh-span @ kh-cursor @ - 0 max cmove\r
-        -1 kh-span +!\r
-        kh.refresh\r
-    THEN\r
-;\r
-    \r
-: KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS )\r
-       CASE\r
-               $ 8D OF kh.get.match    ENDOF\r
-                       0 kh-match-span ! ( reset if any other key )\r
-               $ 48 OF kh.get.older    ENDOF\r
-               $ 50 OF kh.get.newer  ENDOF\r
-               $ 4D OF kh.go.right ENDOF\r
-               $ 4B OF kh.go.left  ENDOF\r
-               $ 91 OF kh.clear.line  ENDOF\r
-               $ 74 OF kh.far.right ENDOF\r
-               $ 73 OF kh.far.left  ENDOF\r
-               $ 53 OF kh.delete  ENDOF\r
-       ENDCASE\r
-;\r
-\r
-: KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal )\r
-       CASE\r
-               $ 41 OF kh.get.older    ENDOF\r
-               $ 42 OF kh.get.newer  ENDOF\r
-               $ 43 OF kh.go.right ENDOF\r
-               $ 44 OF kh.go.left  ENDOF\r
-       ENDCASE\r
-;\r
-\r
-\r
-: KH.SPECIAL.KEY ( char  -- true | false , handle fkeys or arrows, true if handled )\r
-       true >r\r
-       CASE\r
-       \r
-       $ E0 OF key kh.handle.windows.key\r
-       ENDOF\r
-       \r
-       ASCII_ESCAPE OF\r
-               key dup $ 4F = \ for TELNET\r
-               $ 5B = OR \ for regular ANSI terminals\r
-               IF\r
-                       key kh.handle.ansi.key\r
-               ELSE\r
-                       rdrop false >r\r
-               THEN\r
-       ENDOF\r
-       \r
-        ASCII_BACKSPACE OF kh.backspace ENDOF\r
-        ASCII_DELETE    OF kh.backspace ENDOF\r
-        ASCII_CTRL_X    OF kh.clear.line ENDOF\r
-        ASCII_CTRL_A    OF kh.far.left ENDOF\r
-        ASCII_CTRL_E    OF kh.far.right ENDOF\r
-       \r
-       rdrop false >r\r
-       \r
-       ENDCASE\r
-       r>\r
-;\r
-               \r
-: KH.SMART.KEY ( -- char )\r
-    BEGIN\r
-       key dup kh.special.key\r
-    WHILE\r
-       drop\r
-    REPEAT\r
-;\r
-        \r
-: KH.INSCHAR  { charc | repaint -- }\r
-       false -> repaint\r
-       kh-cursor @ kh-span @ <\r
-       IF \r
-\ Move characters up\r
-               kh-buffer kh-cursor @ +  ( -- source )\r
-               dup 1+ ( -- source dest )\r
-               kh-span @ kh-cursor @ - cmove>\r
-               true -> repaint\r
-       THEN\r
-\ write character to buffer\r
-       charc kh-buffer kh-cursor @ + c!\r
-       1 kh-cursor +!\r
-       1 kh-span +!\r
-       repaint\r
-       IF kh.refresh\r
-       ELSE charc emit\r
-       THEN\r
-;\r
-\r
-: EOL? ( char -- flag , true if an end of line character )\r
-       dup 13 =\r
-       swap 10 = OR\r
-;\r
-\r
-: KH.GETLINE ( max -- )\r
-       kh-max !\r
-       kh-span off\r
-       kh-cursor off\r
-       kh-inside off\r
-       kh.rewind\r
-       0 kh-match-span !\r
-       BEGIN\r
-               kh-max @ kh-span @ >\r
-               IF  kh.smart.key\r
-                       dup EOL? not  ( <cr?> )\r
-               ELSE 0 false\r
-               THEN  ( -- char flag )\r
-       WHILE ( -- char )\r
-               kh.inschar\r
-       REPEAT drop\r
-       kh-span @ kh-cursor @ - ?dup\r
-       IF tio.forwards  ( move to end of line )\r
-       THEN\r
-       space\r
-       flushemit\r
-;\r
-\r
-: KH.ACCEPT ( addr max -- numChars )\r
-       swap kh-address !\r
-       kh.getline\r
-       kh-span @ 0>\r
-       IF kh-buffer kh-span @ kh.add.line\r
-       THEN\r
-       kh-span @\r
-;\r
-\r
-: TEST.HISTORY\r
-       4 0 DO\r
-               pad 128 kh.accept\r
-               cr pad swap type cr\r
-       LOOP\r
-;\r
-\r
-}private\r
-\r
-\r
-: HISTORY# ( -- , dump history buffer with numbers)\r
-       cr kh.oldest.line ?dup\r
-       IF\r
-               BEGIN kh.current.num 3 .r ." ) " type ?pause cr\r
-                       kh.forward.line 0=\r
-               WHILE kh.current.line\r
-               REPEAT\r
-       THEN\r
-;\r
-\r
-: HISTORY ( -- , dump history buffer )\r
-       cr kh.oldest.line ?dup\r
-       IF\r
-               BEGIN type ?pause cr\r
-                       kh.forward.line 0=\r
-               WHILE kh.current.line\r
-               REPEAT\r
-       THEN\r
-;\r
-\r
-: XX  ( line# -- , execute line x of history )\r
-       kh.find.line ?dup\r
-       IF count evaluate\r
-       THEN\r
-;\r
-\r
-\r
-: HISTORY.RESET  ( -- , clear history tables )\r
-       kh-history kh_history_size erase\r
-       kh-counter off\r
-;\r
-\r
-: HISTORY.ON ( -- , install history vectors )\r
-       history.reset\r
-       what's accept ['] (accept) =\r
-       IF ['] kh.accept is accept\r
-       THEN\r
-;\r
-\r
-: HISTORY.OFF ( -- , uninstall history vectors )\r
-       what's accept ['] kh.accept =\r
-       IF ['] (accept) is accept\r
-       THEN\r
-;\r
-\r
-\r
-: AUTO.INIT\r
-       auto.init\r
-       history.on\r
-;\r
-: AUTO.TERM\r
-       history.off\r
-       auto.term\r
-;\r
-\r
-if.forgotten history.off\r
-\r
-0 [IF]\r
-history.reset\r
-history.on\r
-[THEN]\r
+\ Command Line History
+\
+\ Author: Phil Burk
+\ Copyright 1988 Phil Burk
+\ Revised 2001 for pForth
+
+0 [IF]
+
+Requires an ANSI compatible terminal.
+
+To get Windows computers to use ANSI mode in their DOS windows,
+Add this line to "C:\CONFIG.SYS" then reboot.
+
+  device=c:\windows\command\ansi.sys
+
+When command line history is on, you can use the UP and DOWN arrow to scroll
+through previous commands. Use the LEFT and RIGHT arrows to edit within a line.
+   CONTROL-A moves to beginning of line.
+   CONTROL-E moves to end of line.
+   CONTROL-X erases entire line.
+
+
+HISTORY#       ( -- , dump history buffer with numbers)
+HISTORY        ( -- , dump history buffer )
+XX             ( line# -- , execute line x of history )
+HISTORY.RESET  ( -- , clear history tables )
+HISTORY.ON     ( -- , install history vectors )
+HISTORY.OFF    ( -- , uninstall history vectors )
+
+[THEN]
+
+include? ESC[ termio.fth
+
+ANEW TASK-HISTORY.FTH
+decimal
+
+private{
+
+\ You can expand the history buffer by increasing this constant!!!!!!!!!!
+2048 constant KH_HISTORY_SIZE
+
+create KH-HISTORY kh_history_size allot
+KH-HISTORY kh_history_size erase
+
+\ An entry in the history buffer consists of
+\   byte  - Count byte = N,
+\   chars - N chars,
+\   short -  line number in Big Endian format,
+\   byte  - another Count byte = N, for reverse scan
+\
+\ The most recent entry is put at the beginning,
+\ older entries are shifted up.
+
+4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 size bytes )
+
+: KH-END ( -- addr , end of history buffer )
+    kh-history kh_history_size +
+;
+
+: LINENUM@ ( addr -- w , stores in BigEndian format )
+    dup c@ 8 shift
+    swap 1+ c@ or
+;
+
+: LINENUM! ( w addr -- )
+    over -8 shift over c!
+    1+ c!
+;
+
+variable KH-LOOK      ( cursor offset into history, point to 1st count byte of line )
+variable KH-MAX
+variable KH-COUNTER       ( 16 bit counter for line # )
+variable KH-SPAN          ( total number of characters in line )
+variable KH-MATCH-SPAN    ( span for matching on shift-up )
+variable KH-CURSOR        ( points to next insertion point )
+variable KH-ADDRESS       ( address to store chars )
+variable KH-INSIDE        ( true if we are scrolling inside the history buffer )
+
+: KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)
+    >r  ( save N )
+    kh-history dup r@ + ( source dest )
+    kh_history_size r> - 0 max move
+;
+
+: KH.NEWEST.LINE  ( -- addr count , most recent line )
+    kh-history count
+;
+
+: KH.REWIND ( -- , move cursor to most recent line )
+    0 kh-look !
+;
+
+: KH.CURRENT.ADDR ( -- $addr , count byte of current line )
+    kh-look @ kh-history +
+;
+
+: KH.CURRENT.LINE ( -- addr count )
+    kh.current.addr count
+;
+
+: KH.COMPARE ( addr count -- flag , true if redundant )
+    kh.newest.line compare 0=   \ note: ANSI COMPARE is different than JForth days
+;
+
+: KH.NUM.ADDR ( -- addr , address of current line's line count )
+    kh.current.line +
+;
+
+: KH.CURRENT.NUM ( -- # , number of current line )
+    kh.num.addr LINENUM@
+;
+
+: KH.ADDR++  ( $addr -- $addr' , convert one kh to previous )
+    count + 3 +
+;
+: KH.ADDR--  ( $addr -- $addr' , convert one kh to next )
+    dup 1- c@   \ get next lines endcount
+    4 +  \ account for lineNum and two count bytes
+    -       \ calc previous address
+;
+
+: KH.ENDCOUNT.ADDR ( -- addr , address of current end count )
+    kh.num.addr 2+
+;
+
+: KH.ADD.LINE ( addr count -- )
+    dup 256 >
+    IF ." KH.ADD.LINE - Too big for history!" 2drop
+    ELSE   ( add to end )
+\ Compare with most recent line.
+        2dup kh.compare
+        IF 2drop
+        ELSE
+            >r ( save count )
+\ Set look pointer to point to first count byte of last string.
+            0 kh-look !
+\ Make room for this line of text and line header.
+\ PLB20100823 Was cell+ which broke on 64-bit code.
+            r@ KH_LINE_EXTRA_SIZE + kh.make.room
+\ Set count bytes at beginning and end.
+            r@ kh-history c!  ( start count )
+            r@ kh.endcount.addr c!
+            kh-counter @ kh.num.addr LINENUM!  ( line )
+\ Number lines modulo 1024
+            kh-counter @ 1+ $ 3FF and kh-counter !
+            kh-history 1+   ( calc destination )
+            r> cmove  ( copy chars into space )
+        THEN
+    THEN
+;
+
+: KH.BACKUP.LINE  { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds }
+    true -> cantmove ( default flag, at end of history )
+\ KH-LOOK points to count at start of current line
+    kh.current.addr c@       \ do we have any lines?
+    IF
+        kh.current.addr kh.addr++ -> addr'
+        addr' kh-end U<      \ within bounds?
+        IF
+            addr' c@     \ older line has chars?
+            IF
+                addr' kh-history - kh-look !
+                false -> cantmove
+            THEN
+        THEN
+    THEN
+    cantmove
+;
+
+: KH.FORWARD.LINE ( -- cantmove? )
+    kh-look @ 0= dup not
+    IF  kh.current.addr kh.addr--
+    kh-history - kh-look !
+    THEN
+;
+
+: KH.OLDEST.LINE   ( -- addr count | 0, oldest in buffer )
+    BEGIN kh.backup.line
+    UNTIL
+    kh.current.line dup 0=
+    IF
+        nip
+    THEN
+;
+
+: KH.FIND.LINE ( line# -- $addr )
+    kh.rewind
+    BEGIN kh.current.num over -
+    WHILE kh.backup.line
+        IF ." Line not in History Buffer!" cr drop 0 exit
+        THEN
+    REPEAT
+    drop kh.current.addr
+;
+
+
+: KH-BUFFER ( -- buffer )
+    kh-address @
+;
+
+: KH.RETURN ( -- , move to beginning of line )
+    0 out !
+    13 emit
+;
+
+: KH.REPLACE.LINE  ( addr count -- , make this the current line of input )
+    kh.return
+    tio.erase.eol
+    dup kh-span !
+    dup kh-cursor !
+    2dup kh-buffer swap cmove
+    type
+;
+
+: KH.GET.MATCH ( -- , search for line with same start )
+    kh-match-span @ 0=  ( keep length for multiple matches )
+    IF kh-span @ kh-match-span !
+    THEN
+    BEGIN
+        kh.backup.line not
+    WHILE
+        kh.current.line drop
+        kh-buffer kh-match-span @ text=
+        IF kh.current.line kh.replace.line
+           exit
+        THEN
+    REPEAT
+;
+
+: KH.FAR.RIGHT
+    kh-span @ kh-cursor @ - dup 0>
+    IF
+        tio.forwards
+        kh-span @ kh-cursor !
+    ELSE drop
+    THEN
+;
+
+: KH.FAR.LEFT ( -- )
+    kh.return
+    kh-cursor off
+;
+
+: KH.GET.OLDER ( -- , goto previous line )
+    kh-inside @
+    IF kh.backup.line drop
+    THEN
+    kh.current.line kh.replace.line
+    kh-inside on
+;
+
+: KH.GET.NEWER ( -- , next line )
+    kh.forward.line
+    IF
+        kh-inside off
+        tib 0
+    ELSE  kh.current.line
+    THEN
+    kh.replace.line
+;
+
+: KH.CLEAR.LINE ( -- , rewind history scrolling and clear line )
+    kh.rewind
+    tib 0 kh.replace.line
+    kh-inside off
+;
+
+: KH.GO.RIGHT  ( -- )
+    kh-cursor @ kh-span @ <
+    IF 1 kh-cursor +!
+       1 tio.forwards
+    THEN
+;
+
+: KH.GO.LEFT ( -- )
+    kh-cursor @ ?dup
+    IF 1- kh-cursor !
+       1 tio.backwards
+    THEN
+;
+
+: KH.REFRESH  ( -- , redraw current line as is )
+    kh.return
+    kh-buffer kh-span @ type
+    tio.erase.eol
+
+    kh.return
+    kh-cursor @ ?dup
+    IF tio.forwards
+    THEN
+
+    kh-span @ out !
+;
+
+: KH.BACKSPACE ( -- , backspace character from buffer and screen )
+    kh-cursor @ ?dup  ( past 0? )
+    IF  kh-span @ <
+        IF  ( inside line )
+            kh-buffer kh-cursor @ +  ( -- source )
+            dup 1- ( -- source dest )
+            kh-span @ kh-cursor @ - cmove
+\            ." Deleted!" cr
+        ELSE
+            backspace
+        THEN
+        -1 kh-span +!
+        -1 kh-cursor +!
+    ELSE bell
+    THEN
+    kh.refresh
+;
+
+: KH.DELETE ( -- , forward delete )
+    kh-cursor @ kh-span @ <  ( before end )
+    IF  ( inside line )
+        kh-buffer kh-cursor @ + 1+ ( -- source )
+        dup 1- ( -- source dest )
+        kh-span @ kh-cursor @ - 0 max cmove
+        -1 kh-span +!
+        kh.refresh
+    THEN
+;
+
+: KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS )
+    CASE
+        $ 8D OF kh.get.match    ENDOF
+            0 kh-match-span ! ( reset if any other key )
+        $ 48 OF kh.get.older    ENDOF
+        $ 50 OF kh.get.newer  ENDOF
+        $ 4D OF kh.go.right ENDOF
+        $ 4B OF kh.go.left  ENDOF
+        $ 91 OF kh.clear.line  ENDOF
+        $ 74 OF kh.far.right ENDOF
+        $ 73 OF kh.far.left  ENDOF
+        $ 53 OF kh.delete  ENDOF
+    ENDCASE
+;
+
+: KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal )
+    CASE
+        $ 41 OF kh.get.older    ENDOF
+        $ 42 OF kh.get.newer  ENDOF
+        $ 43 OF kh.go.right ENDOF
+        $ 44 OF kh.go.left  ENDOF
+    ENDCASE
+;
+
+
+: KH.SPECIAL.KEY ( char  -- true | false , handle fkeys or arrows, true if handled )
+    true >r
+    CASE
+
+    $ E0 OF key kh.handle.windows.key
+    ENDOF
+
+    ASCII_ESCAPE OF
+        key dup $ 4F = \ for TELNET
+        $ 5B = OR \ for regular ANSI terminals
+        IF
+            key kh.handle.ansi.key
+        ELSE
+            rdrop false >r
+        THEN
+    ENDOF
+
+        ASCII_BACKSPACE OF kh.backspace ENDOF
+        ASCII_DELETE    OF kh.backspace ENDOF
+        ASCII_CTRL_X    OF kh.clear.line ENDOF
+        ASCII_CTRL_A    OF kh.far.left ENDOF
+        ASCII_CTRL_E    OF kh.far.right ENDOF
+
+    rdrop false >r
+
+    ENDCASE
+    r>
+;
+
+: KH.SMART.KEY ( -- char )
+    BEGIN
+        key dup kh.special.key
+    WHILE
+        drop
+    REPEAT
+;
+
+: KH.INSCHAR  { charc | repaint -- }
+    false -> repaint
+    kh-cursor @ kh-span @ <
+    IF
+\ Move characters up
+        kh-buffer kh-cursor @ +  ( -- source )
+        dup 1+ ( -- source dest )
+        kh-span @ kh-cursor @ - cmove>
+        true -> repaint
+    THEN
+\ write character to buffer
+    charc kh-buffer kh-cursor @ + c!
+    1 kh-cursor +!
+    1 kh-span +!
+    repaint
+    IF kh.refresh
+    ELSE charc emit
+    THEN
+;
+
+: EOL? ( char -- flag , true if an end of line character )
+    dup 13 =
+    swap 10 = OR
+;
+
+: KH.GETLINE ( max -- )
+    kh-max !
+    kh-span off
+    kh-cursor off
+    kh-inside off
+    kh.rewind
+    0 kh-match-span !
+    BEGIN
+        kh-max @ kh-span @ >
+        IF  kh.smart.key
+            dup EOL? not  ( <cr?> )
+        ELSE 0 false
+        THEN  ( -- char flag )
+    WHILE ( -- char )
+        kh.inschar
+    REPEAT drop
+    kh-span @ kh-cursor @ - ?dup
+    IF tio.forwards  ( move to end of line )
+    THEN
+    space
+    flushemit
+;
+
+: KH.ACCEPT ( addr max -- numChars )
+    swap kh-address !
+    kh.getline
+    kh-span @ 0>
+    IF kh-buffer kh-span @ kh.add.line
+    THEN
+    kh-span @
+;
+
+: TEST.HISTORY
+    4 0 DO
+        pad 128 kh.accept
+        cr pad swap type cr
+    LOOP
+;
+
+}private
+
+
+: HISTORY# ( -- , dump history buffer with numbers)
+    cr kh.oldest.line ?dup
+    IF
+        BEGIN kh.current.num 3 .r ." ) " type ?pause cr
+            kh.forward.line 0=
+        WHILE kh.current.line
+        REPEAT
+    THEN
+;
+
+: HISTORY ( -- , dump history buffer )
+    cr kh.oldest.line ?dup
+    IF
+        BEGIN type ?pause cr
+            kh.forward.line 0=
+        WHILE kh.current.line
+        REPEAT
+    THEN
+;
+
+: XX  ( line# -- , execute line x of history )
+    kh.find.line ?dup
+    IF count evaluate
+    THEN
+;
+
+
+: HISTORY.RESET  ( -- , clear history tables )
+    kh-history kh_history_size erase
+    kh-counter off
+;
+
+: HISTORY.ON ( -- , install history vectors )
+    history.reset
+    what's accept ['] (accept) =
+    IF ['] kh.accept is accept
+    THEN
+;
+
+: HISTORY.OFF ( -- , uninstall history vectors )
+    what's accept ['] kh.accept =
+    IF ['] (accept) is accept
+    THEN
+;
+
+
+: AUTO.INIT
+    auto.init
+    history.on
+;
+: AUTO.TERM
+    history.off
+    auto.term
+;
+
+if.forgotten history.off
+
+0 [IF]
+history.reset
+history.on
+[THEN]

diff --git a/fth/loadhist.fth b/fth/loadhist.fth
index a7168fc..a57f1ba 100644 (file)
--- a/fth/loadhist.fth
+++ b/fth/loadhist.fth
@@ -1,7 +1,7 @@
-\ Load history and save new dictionary.\r
-\ This is not part of the standard build because some computers\r
-\ do not support ANSI terminal I/O.\r
-\r
-include? ESC[ termio.fth\r
-include? HISTORY history.fth\r
-c" pforth.dic" save-forth\r
+\ Load history and save new dictionary.
+\ This is not part of the standard build because some computers
+\ do not support ANSI terminal I/O.
+
+include? ESC[ termio.fth
+include? HISTORY history.fth
+c" pforth.dic" save-forth

diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth
index 5cbfe2c..2e9c2ad 100644 (file)
--- a/fth/loadp4th.fth
+++ b/fth/loadp4th.fth
@@ -1,45 +1,45 @@
-\ @(#) loadp4th.fth 98/01/28 1.3\r
-\ Load various files needed by PForth\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-include? forget  forget.fth\r
-include? >number numberio.fth\r
-include? task-misc1.fth   misc1.fth\r
-include? case    case.fth\r
-include? $=      strings.fth\r
-include? privatize   private.fth\r
-include? (local) ansilocs.fth\r
-include? {       locals.fth\r
-include? fm/mod  math.fth\r
-include? task-misc2.fth misc2.fth\r
-include? [if]    condcomp.fth\r
-\r
-\ load floating point support if basic support is in kernel\r
-exists? F*\r
-   [IF]  include? task-floats.fth floats.fth\r
-   [THEN]\r
-\r
-\ useful but optional stuff follows --------------------\r
-\r
-include? task-member.fth   member.fth\r
-include? :struct c_struct.fth\r
-include? smif{   smart_if.fth\r
-include? file?   filefind.fth\r
-include? see     see.fth\r
-include? words.like wordslik.fth\r
-include? trace   trace.fth\r
-include? ESC[    termio.fth\r
-include? HISTORY history.fth\r
-\r
-map\r
+\ @(#) loadp4th.fth 98/01/28 1.3
+\ Load various files needed by PForth
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+include? forget  forget.fth
+include? >number numberio.fth
+include? task-misc1.fth   misc1.fth
+include? case    case.fth
+include? $=      strings.fth
+include? privatize   private.fth
+include? (local) ansilocs.fth
+include? {       locals.fth
+include? fm/mod  math.fth
+include? task-misc2.fth misc2.fth
+include? [if]    condcomp.fth
+
+\ load floating point support if basic support is in kernel
+exists? F*
+   [IF]  include? task-floats.fth floats.fth
+   [THEN]
+
+\ useful but optional stuff follows --------------------
+
+include? task-member.fth   member.fth
+include? :struct c_struct.fth
+include? smif{   smart_if.fth
+include? file?   filefind.fth
+include? see     see.fth
+include? words.like wordslik.fth
+include? trace   trace.fth
+include? ESC[    termio.fth
+include? HISTORY history.fth
+
+map

diff --git a/fth/locals.fth b/fth/locals.fth
index eb02ceb..a145781 100644 (file)
--- a/fth/locals.fth
+++ b/fth/locals.fth
@@ -1,77 +1,77 @@
-\ @(#) $M$ 98/01/26 1.2\r
-\ standard { v0 v1 ... vn | l0 l1 .. lm -- } syntax\r
-\ based on ANSI basis words (LOCAL) and TO\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-\ MOD: PLB 2/11/00 Allow EOL and \ between { }.\r
-\r
-anew task-locals.fth\r
-\r
-private{\r
-variable loc-temp-mode    \ if true, declaring temporary variables\r
-variable loc-comment-mode \ if true, in comment section\r
-variable loc-done\r
-}private\r
-\r
-: { ( <local-declaration}> -- )\r
-       loc-done off\r
-       loc-temp-mode off\r
-       loc-comment-mode off\r
-       BEGIN\r
-               bl word count\r
-               dup 0>           \ make sure we are not at the end of a line\r
-               IF\r
-                       over c@\r
-                       CASE\r
-       \ handle special characters\r
-                       ascii }  OF  loc-done on          2drop  ENDOF\r
-                       ascii |  OF  loc-temp-mode on     2drop  ENDOF\r
-                       ascii -  OF  loc-comment-mode on  2drop  ENDOF\r
-                       ascii )  OF  ." { ... ) imbalance!" cr abort  ENDOF\r
-                       ascii \  OF  postpone \  2drop ENDOF   \ Forth comment\r
-                       \r
-       \ process name\r
-                       >r  ( save char )\r
-                       ( addr len )\r
-                       loc-comment-mode @\r
-                       IF\r
-                               2drop\r
-                       ELSE\r
-       \ if in temporary mode, assign local var = 0\r
-                               loc-temp-mode @\r
-                               IF compile false\r
-                               THEN\r
-       \ otherwise take value from stack\r
-                               (local)\r
-                       THEN\r
-                       r>\r
-                       ENDCASE\r
-               ELSE\r
-                       2drop refill 0= abort" End of input while defining local variables!"\r
-               THEN\r
-               loc-done @\r
-       UNTIL\r
-       0 0 (local)\r
-; immediate\r
-\r
-privatize\r
-\r
-\ tests\r
-: tlv1  { n -- }  n  dup n *  dup n *  ;\r
-\r
-: tlv2 { v1 v2 | l1 l2 -- }\r
-       v1 . v2 . cr\r
-       v1 v2 + -> l1\r
-       l1 . l2 . cr\r
-;\r
+\ @(#) $M$ 98/01/26 1.2
+\ standard { v0 v1 ... vn | l0 l1 .. lm -- } syntax
+\ based on ANSI basis words (LOCAL) and TO
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+\ MOD: PLB 2/11/00 Allow EOL and \ between { }.
+
+anew task-locals.fth
+
+private{
+variable loc-temp-mode    \ if true, declaring temporary variables
+variable loc-comment-mode \ if true, in comment section
+variable loc-done
+}private
+
+: { ( <local-declaration}> -- )
+    loc-done off
+    loc-temp-mode off
+    loc-comment-mode off
+    BEGIN
+        bl word count
+        dup 0>           \ make sure we are not at the end of a line
+        IF
+            over c@
+            CASE
+    \ handle special characters
+            ascii }  OF  loc-done on          2drop  ENDOF
+            ascii |  OF  loc-temp-mode on     2drop  ENDOF
+            ascii -  OF  loc-comment-mode on  2drop  ENDOF
+            ascii )  OF  ." { ... ) imbalance!" cr abort  ENDOF
+            ascii \  OF  postpone \  2drop ENDOF   \ Forth comment
+
+    \ process name
+            >r  ( save char )
+            ( addr len )
+            loc-comment-mode @
+            IF
+                2drop
+            ELSE
+    \ if in temporary mode, assign local var = 0
+                loc-temp-mode @
+                IF compile false
+                THEN
+    \ otherwise take value from stack
+                (local)
+            THEN
+            r>
+            ENDCASE
+        ELSE
+            2drop refill 0= abort" End of input while defining local variables!"
+        THEN
+        loc-done @
+    UNTIL
+    0 0 (local)
+; immediate
+
+privatize
+
+\ tests
+: tlv1  { n -- }  n  dup n *  dup n *  ;
+
+: tlv2 { v1 v2 | l1 l2 -- }
+    v1 . v2 . cr
+    v1 v2 + -> l1
+    l1 . l2 . cr
+;

diff --git a/fth/math.fth b/fth/math.fth
index bad711d..891849c 100644 (file)
--- a/fth/math.fth
+++ b/fth/math.fth
@@ -1,89 +1,89 @@
-\ @(#) math.fth 98/01/26 1.2\r
-\ Extended Math routines\r
-\ FM/MOD SM/REM\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-anew task-math.fth\r
-decimal\r
-\r
-: FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored }\r
-       dl dh dabs -> dhp -> dlp\r
-       nn abs -> nnp\r
-       dlp dhp nnp um/mod -> quo -> rem\r
-       dh 0<  \r
-       IF  \ negative dividend\r
-               nn 0< \r
-               IF   \ negative divisor\r
-                       rem negate -> rem\r
-               ELSE  \ positive divisor\r
-                       rem 0=\r
-                       IF\r
-                               quo negate -> quo\r
-                       ELSE\r
-                               quo 1+ negate -> quo\r
-                               nnp rem - -> rem\r
-                       THEN\r
-               THEN\r
-       ELSE  \ positive dividend\r
-               nn 0<  \r
-               IF  \ negative divisor\r
-                       rem 0=\r
-                       IF\r
-                               quo negate -> quo\r
-                       ELSE\r
-                               nnp rem - negate -> rem\r
-                               quo 1+ negate -> quo\r
-                       THEN\r
-               THEN\r
-       THEN\r
-       rem quo\r
-;\r
-\r
-: SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric }\r
-       dl dh dabs -> dhp -> dlp\r
-       nn abs -> nnp\r
-       dlp dhp nnp um/mod -> quo -> rem\r
-       dh 0<  \r
-       IF  \ negative dividend\r
-               rem negate -> rem\r
-               nn 0> \r
-               IF   \ positive divisor\r
-                       quo negate -> quo\r
-               THEN\r
-       ELSE  \ positive dividend\r
-               nn 0<  \r
-               IF  \ negative divisor\r
-                       quo negate -> quo\r
-               THEN\r
-       THEN\r
-       rem quo\r
-;\r
-\r
-\r
-: /MOD ( a b -- rem quo )\r
-       >r s>d r> sm/rem\r
-;\r
-\r
-: MOD ( a b -- rem )\r
-       /mod drop\r
-;\r
-\r
-: */MOD ( a b c -- rem a*b/c , use double precision intermediate value )\r
-       >r m*\r
-       r> sm/rem\r
-;\r
-: */ ( a b c -- a*b/c , use double precision intermediate value )\r
-       */mod\r
-       nip\r
-;\r
+\ @(#) math.fth 98/01/26 1.2
+\ Extended Math routines
+\ FM/MOD SM/REM
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+anew task-math.fth
+decimal
+
+: FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored }
+    dl dh dabs -> dhp -> dlp
+    nn abs -> nnp
+    dlp dhp nnp um/mod -> quo -> rem
+    dh 0<
+    IF  \ negative dividend
+        nn 0<
+        IF   \ negative divisor
+            rem negate -> rem
+        ELSE  \ positive divisor
+            rem 0=
+            IF
+                quo negate -> quo
+            ELSE
+                quo 1+ negate -> quo
+                nnp rem - -> rem
+            THEN
+        THEN
+    ELSE  \ positive dividend
+        nn 0<
+        IF  \ negative divisor
+            rem 0=
+            IF
+                quo negate -> quo
+            ELSE
+                nnp rem - negate -> rem
+                quo 1+ negate -> quo
+            THEN
+        THEN
+    THEN
+    rem quo
+;
+
+: SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric }
+    dl dh dabs -> dhp -> dlp
+    nn abs -> nnp
+    dlp dhp nnp um/mod -> quo -> rem
+    dh 0<
+    IF  \ negative dividend
+        rem negate -> rem
+        nn 0>
+        IF   \ positive divisor
+            quo negate -> quo
+        THEN
+    ELSE  \ positive dividend
+        nn 0<
+        IF  \ negative divisor
+            quo negate -> quo
+        THEN
+    THEN
+    rem quo
+;
+
+
+: /MOD ( a b -- rem quo )
+    >r s>d r> sm/rem
+;
+
+: MOD ( a b -- rem )
+    /mod drop
+;
+
+: */MOD ( a b c -- rem a*b/c , use double precision intermediate value )
+    >r m*
+    r> sm/rem
+;
+: */ ( a b c -- a*b/c , use double precision intermediate value )
+    */mod
+    nip
+;

diff --git a/fth/member.fth b/fth/member.fth
index 160e95f..5aa84bd 100644 (file)
--- a/fth/member.fth
+++ b/fth/member.fth
@@ -1,155 +1,155 @@
-\ @(#) member.fth 98/01/26 1.2\r
-\ This files, along with c_struct.fth, supports the definition of\r
-\ structure members similar to those used in 'C'.\r
-\\r
-\ Some of this same code is also used by ODE,\r
-\ the Object Development Environment.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ MOD: PLB 1/16/87 Use abort" instead of er.report.\r
-\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.\r
-\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.\r
-\ MOD: PLB 7/31/88 Add USHORT and UBYTE.\r
-\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.\r
-\ MOD: RDG 9/19/90 Add floating point member support.\r
-\ MOD: PLB 6/10/91 Add RPTR\r
-\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!\r
-\ 941102 RDG port to pforth\r
-\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.\r
-\ 960710 PLB align long members for SUN\r
-\r
-ANEW TASK-MEMBER.FTH\r
-decimal\r
-\r
-: FIND.BODY   ( -- , pfa true | $name false , look for word in dict. )\r
-\ Return address of parameter data.\r
-     bl word find\r
-     IF  >body true\r
-     ELSE false\r
-     THEN\r
-;\r
-\r
-\ Variables shared with object oriented code.\r
-    VARIABLE OB-STATE  ( Compilation state. )\r
-    VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )\r
-    1 constant OB_DEF_CLASS   ( defining a class )\r
-    2 constant OB_DEF_STRUCT  ( defining a structure )\r
-\r
-4 constant OB_OFFSET_SIZE\r
-\r
-: OB.OFFSET@ ( member_def -- offset ) @ ;\r
-: OB.OFFSET, ( value -- ) , ;\r
-: OB.SIZE@ ( member_def -- offset )\r
-        ob_offset_size + @ ;\r
-: OB.SIZE, ( value -- ) , ;\r
-\r
-( Members are associated with an offset from the base of a structure. )\r
-: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)\r
-       dup >r  ( -- +-b , save #bytes )\r
-       ABS     ( -- |+-b| )\r
-       ob-current-class @ ( -- b addr-space)\r
-       tuck @          ( as #b c , current space needed )\r
-       over 3 and 0=        ( multiple of four? )\r
-       IF\r
-               aligned\r
-       ELSE\r
-               over 1 and 0=   ( multiple of two? )\r
-               IF\r
-                       even-up\r
-               THEN\r
-       THEN\r
-       swap over + rot !    ( update space needed )\r
-\ Save data in member definition. %M\r
-       ob.offset,    ( save old offset for ivar )\r
-       r> ob.size,   ( store size in bytes for ..! and ..@ )\r
-;\r
-\r
-\ Unions allow one to address the same memory as different members.\r
-\ Unions work by saving the current offset for members on\r
-\ the stack and then reusing it for different members.\r
-: UNION{  ( -- offset , Start union definition. )\r
-    ob-current-class @ @\r
-;\r
-\r
-: }UNION{ ( old-offset -- new-offset , Middle of union )\r
-    union{     ( Get current for }UNION to compare )\r
-    swap ob-current-class @ !  ( Set back to old )\r
-;\r
-\r
-: }UNION ( offset -- , Terminate union definition, check lengths. )\r
-    union{ = NOT\r
-    abort" }UNION - Two parts of UNION are not the same size!"\r
-;\r
-\r
-\ Make members compile their offset, for "disposable includes".\r
-: OB.MEMBER  ( #bytes -- , make room in an object at compile time)\r
-           ( -- offset , run time for structure )\r
-    CREATE ob.make.member immediate\r
-    DOES> ob.offset@  ( get offset ) ?literal\r
-;\r
-\r
-: OB.FINDIT  ( <thing> -- pfa , get pfa of thing or error )\r
-    find.body not\r
-    IF cr count type ."    ???"\r
-       true abort" OB.FINDIT - Word not found!"\r
-    THEN\r
-;\r
-\r
-: OB.STATS ( member_pfa --  offset #bytes )\r
-    dup ob.offset@ swap\r
-    ob.size@\r
-;\r
-\r
-: OB.STATS? ( <member> -- offset #bytes )\r
-    ob.findit ob.stats\r
-;\r
-\r
-: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )\r
-    ob.findit @\r
-    ?literal\r
-; immediate\r
-\r
-\ Basic word for defining structure members.\r
-: BYTES ( #bytes -- , error check for structure only )\r
-    ob-state @ ob_def_struct = not\r
-    abort" BYTES - Only valid in :STRUCT definitions."\r
-    ob.member\r
-;\r
-\r
-\ Declare various types of structure members.\r
-\ Negative size indicates a signed member.\r
-: BYTE ( <name> -- , declare space for a byte )\r
-    -1 bytes ;\r
-\r
-: SHORT ( <name> -- , declare space for a 16 bit value )\r
-    -2 bytes ;\r
-\r
-: LONG ( <name> -- )\r
-    cell bytes ;\r
-\r
-: UBYTE ( <name> -- , declare space for signed  byte )\r
-    1 bytes ;\r
-\r
-: USHORT ( <name> -- , declare space for signed 16 bit value )\r
-    2 bytes ;\r
-\r
-\r
-\ Aliases\r
-: APTR    ( <name> -- ) long ;\r
-: RPTR    ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001\r
-: ULONG   ( <name> -- ) long ;\r
-\r
-: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )\r
-    [compile] sizeof() bytes\r
-;\r
+\ @(#) member.fth 98/01/26 1.2
+\ This files, along with c_struct.fth, supports the definition of
+\ structure members similar to those used in 'C'.
+\
+\ Some of this same code is also used by ODE,
+\ the Object Development Environment.
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ MOD: PLB 1/16/87 Use abort" instead of er.report.
+\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.
+\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.
+\ MOD: PLB 7/31/88 Add USHORT and UBYTE.
+\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.
+\ MOD: RDG 9/19/90 Add floating point member support.
+\ MOD: PLB 6/10/91 Add RPTR
+\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!
+\ 941102 RDG port to pforth
+\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.
+\ 960710 PLB align long members for SUN
+
+ANEW TASK-MEMBER.FTH
+decimal
+
+: FIND.BODY   ( -- , pfa true | $name false , look for word in dict. )
+\ Return address of parameter data.
+     bl word find
+     IF  >body true
+     ELSE false
+     THEN
+;
+
+\ Variables shared with object oriented code.
+    VARIABLE OB-STATE  ( Compilation state. )
+    VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
+    1 constant OB_DEF_CLASS   ( defining a class )
+    2 constant OB_DEF_STRUCT  ( defining a structure )
+
+4 constant OB_OFFSET_SIZE
+
+: OB.OFFSET@ ( member_def -- offset ) @ ;
+: OB.OFFSET, ( value -- ) , ;
+: OB.SIZE@ ( member_def -- offset )
+        ob_offset_size + @ ;
+: OB.SIZE, ( value -- ) , ;
+
+( Members are associated with an offset from the base of a structure. )
+: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
+    dup >r  ( -- +-b , save #bytes )
+    ABS     ( -- |+-b| )
+    ob-current-class @ ( -- b addr-space)
+    tuck @          ( as #b c , current space needed )
+    over 3 and 0=        ( multiple of four? )
+    IF
+        aligned
+    ELSE
+        over 1 and 0=   ( multiple of two? )
+        IF
+            even-up
+        THEN
+    THEN
+    swap over + rot !    ( update space needed )
+\ Save data in member definition. %M
+    ob.offset,    ( save old offset for ivar )
+    r> ob.size,   ( store size in bytes for ..! and ..@ )
+;
+
+\ Unions allow one to address the same memory as different members.
+\ Unions work by saving the current offset for members on
+\ the stack and then reusing it for different members.
+: UNION{  ( -- offset , Start union definition. )
+    ob-current-class @ @
+;
+
+: }UNION{ ( old-offset -- new-offset , Middle of union )
+    union{     ( Get current for }UNION to compare )
+    swap ob-current-class @ !  ( Set back to old )
+;
+
+: }UNION ( offset -- , Terminate union definition, check lengths. )
+    union{ = NOT
+    abort" }UNION - Two parts of UNION are not the same size!"
+;
+
+\ Make members compile their offset, for "disposable includes".
+: OB.MEMBER  ( #bytes -- , make room in an object at compile time)
+           ( -- offset , run time for structure )
+    CREATE ob.make.member immediate
+    DOES> ob.offset@  ( get offset ) ?literal
+;
+
+: OB.FINDIT  ( <thing> -- pfa , get pfa of thing or error )
+    find.body not
+    IF cr count type ."    ???"
+       true abort" OB.FINDIT - Word not found!"
+    THEN
+;
+
+: OB.STATS ( member_pfa --  offset #bytes )
+    dup ob.offset@ swap
+    ob.size@
+;
+
+: OB.STATS? ( <member> -- offset #bytes )
+    ob.findit ob.stats
+;
+
+: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
+    ob.findit @
+    ?literal
+; immediate
+
+\ Basic word for defining structure members.
+: BYTES ( #bytes -- , error check for structure only )
+    ob-state @ ob_def_struct = not
+    abort" BYTES - Only valid in :STRUCT definitions."
+    ob.member
+;
+
+\ Declare various types of structure members.
+\ Negative size indicates a signed member.
+: BYTE ( <name> -- , declare space for a byte )
+    -1 bytes ;
+
+: SHORT ( <name> -- , declare space for a 16 bit value )
+    -2 bytes ;
+
+: LONG ( <name> -- )
+    cell bytes ;
+
+: UBYTE ( <name> -- , declare space for signed  byte )
+    1 bytes ;
+
+: USHORT ( <name> -- , declare space for signed 16 bit value )
+    2 bytes ;
+
+
+\ Aliases
+: APTR    ( <name> -- ) long ;
+: RPTR    ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001
+: ULONG   ( <name> -- ) long ;
+
+: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
+    [compile] sizeof() bytes
+;

diff --git a/fth/misc1.fth b/fth/misc1.fth
index 373e495..da9c154 100644 (file)
--- a/fth/misc1.fth
+++ b/fth/misc1.fth
@@ -1,177 +1,177 @@
-\ @(#) misc1.fth 98/01/26 1.2\r
-\ miscellaneous words\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-anew task-misc1.fth\r
-decimal\r
-\r
-: >> rshift ;\r
-: << lshift ;\r
-\r
-: (WARNING")  ( flag $message -- )\r
-    swap\r
-    IF count type\r
-    ELSE drop\r
-    THEN\r
-;\r
-\r
-: WARNING" ( flag <message> -- , print warning if true. )\r
-       [compile] "  ( compile message )\r
-       state @\r
-       IF  compile (warning")\r
-       ELSE (warning")\r
-       THEN\r
-; IMMEDIATE\r
-\r
-: (ABORT")  ( flag $message -- )\r
-    swap\r
-    IF\r
-       count type cr\r
-       err_abortq throw\r
-    ELSE drop\r
-    THEN\r
-;\r
-\r
-: ABORT" ( flag <message> -- , print warning if true. )\r
-       [compile] "  ( compile message )\r
-       state @\r
-       IF  compile (abort")\r
-       ELSE (abort")\r
-       THEN\r
-; IMMEDIATE\r
-\r
-\r
-: ?PAUSE ( -- , Pause if key hit. )\r
-    ?terminal\r
-    IF  key drop cr ." Hit space to continue, any other key to abort:"\r
-        key dup emit BL = not abort" Terminated"\r
-    THEN\r
-;\r
-\r
-60 constant #cols\r
-\r
-: CR?  ( -- , do CR if near end )\r
-    OUT @ #cols 16 - 10 max >\r
-    IF cr\r
-    THEN\r
-;\r
-\r
-: CLS ( -- clear screen )\r
-       40 0 do cr loop\r
-;\r
-: PAGE ( -- , clear screen, compatible with Brodie )\r
-       cls\r
-;\r
-\r
-: $ ( <number> -- N , convert next number as hex )\r
-    base @ hex\r
-    bl lword number? num_type_single = not\r
-    abort" Not a single number!"\r
-    swap base !\r
-    state @\r
-    IF [compile] literal\r
-    THEN\r
-; immediate\r
-\r
-: .HX   ( nibble -- )\r
-       dup 9 >\r
-       IF    $ 37\r
-       ELSE  $ 30\r
-       THEN  + emit\r
-;\r
-\r
-variable TAB-WIDTH  8 TAB-WIDTH !\r
-: TAB  ( -- , tab over to next stop )\r
-    out @ tab-width @ mod\r
-    tab-width @   swap - spaces\r
-;\r
-\r
-\ Vocabulary listing\r
-: WORDS  ( -- )\r
-       0 latest\r
-       BEGIN  dup 0<>\r
-       WHILE  dup id. tab cr? ?pause\r
-               prevname\r
-               swap 1+ swap\r
-       REPEAT drop\r
-       cr . ."  words" cr\r
-;\r
-\r
-: VLIST words ;\r
-\r
-variable CLOSEST-NFA\r
-variable CLOSEST-XT\r
-\r
-: >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )\r
-       0 closest-nfa !\r
-       0 closest-xt !\r
-       latest\r
-       BEGIN  dup 0<>\r
-               IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <\r
-                       IF true  ( addr below this cfa, can't be it)\r
-                       ELSE ( -- addr nfa )\r
-                               2dup name>  ( addr nfa addr xt ) =\r
-                               IF ( found it ! ) dup closest-nfa ! false\r
-                               ELSE dup name> closest-xt @ >\r
-                                       IF dup closest-nfa ! dup name> closest-xt !\r
-                                       THEN\r
-                                       true\r
-                               THEN\r
-                       THEN\r
-               ELSE false\r
-               THEN\r
-       WHILE  \r
-           prevname\r
-       REPEAT ( -- cfa nfa )\r
-       2drop\r
-       closest-nfa @\r
-;\r
-\r
-: @EXECUTE  ( addr -- , execute if non-zero )\r
-       x@ ?dup\r
-       IF execute\r
-       THEN\r
-;\r
-\r
-: TOLOWER ( char -- char_lower )\r
-    dup ascii [ <\r
-    IF  dup ascii @ >\r
-               IF ascii A - ascii a +\r
-               THEN\r
-    THEN\r
-;\r
-\r
-: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )\r
-\ save current input state and switch to passed in string\r
-       source >r >r\r
-       set-source\r
-       -1 push-source-id\r
-       >in @ >r\r
-       0 >in !\r
-\ interpret the string\r
-       interpret\r
-\ restore input state\r
-       pop-source-id drop\r
-       r> >in !\r
-       r> r> set-source\r
-;\r
-\r
-: \S ( -- , comment out rest of file )\r
-    source-id\r
-    IF\r
-       BEGIN \ using REFILL is safer than popping SOURCE-ID\r
-               refill 0=\r
-       UNTIL\r
-    THEN\r
-;\r
+\ @(#) misc1.fth 98/01/26 1.2
+\ miscellaneous words
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+anew task-misc1.fth
+decimal
+
+: >> rshift ;
+: << lshift ;
+
+: (WARNING")  ( flag $message -- )
+    swap
+    IF count type
+    ELSE drop
+    THEN
+;
+
+: WARNING" ( flag <message> -- , print warning if true. )
+    [compile] "  ( compile message )
+    state @
+    IF  compile (warning")
+    ELSE (warning")
+    THEN
+; IMMEDIATE
+
+: (ABORT")  ( flag $message -- )
+    swap
+    IF
+        count type cr
+        err_abortq throw
+    ELSE drop
+    THEN
+;
+
+: ABORT" ( flag <message> -- , print warning if true. )
+    [compile] "  ( compile message )
+    state @
+    IF  compile (abort")
+    ELSE (abort")
+    THEN
+; IMMEDIATE
+
+
+: ?PAUSE ( -- , Pause if key hit. )
+    ?terminal
+    IF  key drop cr ." Hit space to continue, any other key to abort:"
+        key dup emit BL = not abort" Terminated"
+    THEN
+;
+
+60 constant #cols
+
+: CR?  ( -- , do CR if near end )
+    OUT @ #cols 16 - 10 max >
+    IF cr
+    THEN
+;
+
+: CLS ( -- clear screen )
+    40 0 do cr loop
+;
+: PAGE ( -- , clear screen, compatible with Brodie )
+    cls
+;
+
+: $ ( <number> -- N , convert next number as hex )
+    base @ hex
+    bl lword number? num_type_single = not
+    abort" Not a single number!"
+    swap base !
+    state @
+    IF [compile] literal
+    THEN
+; immediate
+
+: .HX   ( nibble -- )
+    dup 9 >
+    IF    $ 37
+    ELSE  $ 30
+    THEN  + emit
+;
+
+variable TAB-WIDTH  8 TAB-WIDTH !
+: TAB  ( -- , tab over to next stop )
+    out @ tab-width @ mod
+    tab-width @   swap - spaces
+;
+
+\ Vocabulary listing
+: WORDS  ( -- )
+    0 latest
+    BEGIN  dup 0<>
+    WHILE  dup id. tab cr? ?pause
+        prevname
+        swap 1+ swap
+    REPEAT drop
+    cr . ."  words" cr
+;
+
+: VLIST words ;
+
+variable CLOSEST-NFA
+variable CLOSEST-XT
+
+: >NAME  ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
+    0 closest-nfa !
+    0 closest-xt !
+    latest
+    BEGIN  dup 0<>
+        IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
+            IF true  ( addr below this cfa, can't be it)
+            ELSE ( -- addr nfa )
+                2dup name>  ( addr nfa addr xt ) =
+                IF ( found it ! ) dup closest-nfa ! false
+                ELSE dup name> closest-xt @ >
+                    IF dup closest-nfa ! dup name> closest-xt !
+                    THEN
+                    true
+                THEN
+            THEN
+        ELSE false
+        THEN
+    WHILE
+        prevname
+    REPEAT ( -- cfa nfa )
+    2drop
+    closest-nfa @
+;
+
+: @EXECUTE  ( addr -- , execute if non-zero )
+    x@ ?dup
+    IF execute
+    THEN
+;
+
+: TOLOWER ( char -- char_lower )
+    dup ascii [ <
+    IF  dup ascii @ >
+        IF ascii A - ascii a +
+        THEN
+    THEN
+;
+
+: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
+\ save current input state and switch to passed in string
+    source >r >r
+    set-source
+    -1 push-source-id
+    >in @ >r
+    0 >in !
+\ interpret the string
+    interpret
+\ restore input state
+    pop-source-id drop
+    r> >in !
+    r> r> set-source
+;
+
+: \S ( -- , comment out rest of file )
+    source-id
+    IF
+        BEGIN \ using REFILL is safer than popping SOURCE-ID
+            refill 0=
+        UNTIL
+    THEN
+;

diff --git a/fth/misc2.fth b/fth/misc2.fth
index 7d1dafa..cf20173 100644 (file)
--- a/fth/misc2.fth
+++ b/fth/misc2.fth
@@ -1,235 +1,235 @@
-\ @(#) misc2.fth 98/01/26 1.2\r
-\ Utilities for PForth extracted from HMSL\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 00001 9/14/92 Added call, 'c w->s\r
-\ 00002 11/23/92 Moved redef of : to loadcom.fth\r
-\r
-anew task-misc2.fth\r
-\r
-: 'N  ( <name> -- , make 'n state smart )\r
-       bl word find\r
-       IF\r
-               state @\r
-               IF      namebase - ( make nfa relocatable )\r
-                       [compile] literal       ( store nfa of word to be compiled )\r
-                       compile namebase+\r
-               THEN\r
-       THEN\r
-; IMMEDIATE\r
-\r
-: ?LITERAL  ( n -- , do literal if compiling )\r
-       state @\r
-       IF [compile] literal\r
-       THEN\r
-;\r
-\r
-: 'c ( <name> -- xt , state sensitive ' )\r
-       ' ?literal\r
-; immediate\r
-\r
-variable if-debug\r
-\r
-decimal\r
-create msec-delay 10000 ,  ( default for SUN )\r
-: (MSEC) ( #msecs -- )\r
-    0\r
-    do  msec-delay @ 0\r
-        do loop\r
-    loop\r
-;\r
-\r
-defer msec\r
-' (msec) is msec\r
-\r
-: SHIFT ( val n -- val<<n )\r
-       dup 0<\r
-       IF negate arshift\r
-       ELSE lshift\r
-       THEN\r
-;\r
-\r
-\r
-variable rand-seed here rand-seed !\r
-: random ( -- random_number )\r
-    rand-seed @\r
-    31421 * 6927 + \r
-    65535 and dup rand-seed !\r
-;\r
-: choose  ( range -- random_number , in range )\r
-    random * -16 shift\r
-;\r
-\r
-: wchoose ( hi lo -- random_number )\r
-    tuck - choose +\r
-;\r
-\r
-\r
-\ sort top two items on stack.\r
-: 2sort ( a b -- a<b | b<a , largest on top of stack)\r
-    2dup >\r
-    if swap\r
-    then\r
-;\r
-\r
-\ sort top two items on stack.\r
-: -2sort ( a b -- a>b | b>a , smallest on top of stack)\r
-    2dup <\r
-    if swap\r
-    then\r
-;\r
-\r
-: barray  ( #bytes -- ) ( index -- addr )\r
-    create allot\r
-    does>  +\r
-;\r
-\r
-: warray  ( #words -- ) ( index -- addr )\r
-    create 2* allot\r
-    does> swap 2* +\r
-;\r
-\r
-: array  ( #cells -- ) ( index -- addr )\r
-    create cell* allot\r
-    does> swap cell* +\r
-;\r
-\r
-: .bin  ( n -- , print in binary )\r
-    base @ binary swap . base !\r
-;\r
-: .dec  ( n -- )\r
-    base @ decimal swap . base !\r
-;\r
-: .hex  ( n -- )\r
-    base @ hex swap . base !\r
-;\r
-\r
-: B->S ( c -- c' , sign extend byte )\r
-       dup $ 80 and \r
-       IF\r
-               $ FFFFFF00 or\r
-       ELSE\r
-               $ 000000FF and\r
-       THEN\r
-;\r
-: W->S ( 16bit-signed -- 32bit-signed )\r
-       dup $ 8000 and\r
-       if\r
-               $ FFFF0000 or\r
-       ELSE\r
-               $ 0000FFFF and\r
-       then\r
-;\r
-\r
-: WITHIN { n1 n2 n3 -- flag }\r
-       n2 n3 <=\r
-       IF\r
-               n2 n1 <=\r
-               n1 n3 <  AND\r
-       ELSE\r
-               n2 n1 <=\r
-               n1 n3 <  OR\r
-       THEN\r
-;\r
-\r
-: MOVE ( src dst num -- )\r
-       >r 2dup - 0<\r
-       IF\r
-               r> CMOVE>\r
-       ELSE\r
-               r> CMOVE\r
-       THEN\r
-;\r
-\r
-: ERASE ( caddr num -- )\r
-       dup 0>\r
-       IF\r
-               0 fill\r
-       ELSE\r
-               2drop\r
-       THEN\r
-;\r
-\r
-: BLANK ( addr u -- , set memory to blank )\r
-       DUP 0>\r
-       IF\r
-               BL FILL \r
-       ELSE \r
-               2DROP \r
-       THEN \r
-;\r
-\r
-\ Obsolete but included for CORE EXT word set.\r
-: QUERY REFILL DROP ;\r
-VARIABLE SPAN\r
-: EXPECT accept span ! ;\r
-: TIB source drop ;\r
-\r
-\r
-: UNUSED ( -- unused , dictionary space )\r
-       CODELIMIT HERE -\r
-;\r
-\r
-: MAP  ( -- , dump interesting dictionary info )\r
-       ." Code Segment" cr\r
-       ."    CODEBASE           = " codebase .hex cr\r
-       ."    HERE               = " here .hex cr\r
-       ."    CODELIMIT          = " codelimit .hex cr\r
-       ."    Compiled Code Size = " here codebase - . cr\r
-       ."    CODE-SIZE          = " code-size @ . cr\r
-       ."    Code Room UNUSED   = " UNUSED . cr\r
-       ." Name Segment" cr\r
-       ."    NAMEBASE           = " namebase .hex cr\r
-       ."    HEADERS-PTR @      = " headers-ptr @ .hex cr\r
-       ."    NAMELIMIT          = " namelimit .hex cr\r
-       ."    CONTEXT @          = " context @ .hex cr\r
-       ."    LATEST             = " latest .hex  ."  = " latest id. cr\r
-       ."    Compiled Name size = " headers-ptr @ namebase - . cr\r
-       ."    HEADERS-SIZE       = " headers-size @ . cr\r
-       ."    Name Room Left     = " namelimit headers-ptr @ - . cr\r
-;\r
-\r
-\r
-\ Search for substring S2 in S1\r
-: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }\r
-\ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr\r
-\ if true, s1 contains s2 at addr3 with cnt3 chars remaining\r
-\ if false, s3 = s1    \r
-       addr1 -> addr3\r
-       cnt1 -> cnt3\r
-       cnt1 cnt2 < not\r
-       IF\r
-           cnt1 cnt2 - 1+ 0\r
-               DO\r
-                       true -> flag\r
-                       cnt2 0\r
-                       ?DO\r
-                               addr2 i chars + c@\r
-                               addr1 i j + chars + c@ <> \ mismatch?\r
-                               IF\r
-                                       false -> flag\r
-                                       LEAVE\r
-                               THEN\r
-                       LOOP\r
-                       flag\r
-                       IF\r
-                               addr1 i chars + -> addr3\r
-                               cnt1 i - -> cnt3\r
-                               LEAVE\r
-                       THEN\r
-               LOOP\r
-       THEN\r
-       addr3 cnt3 flag\r
-;\r
-\r
+\ @(#) misc2.fth 98/01/26 1.2
+\ Utilities for PForth extracted from HMSL
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\
+\ 00001 9/14/92 Added call, 'c w->s
+\ 00002 11/23/92 Moved redef of : to loadcom.fth
+
+anew task-misc2.fth
+
+: 'N  ( <name> -- , make 'n state smart )
+    bl word find
+    IF
+        state @
+        IF  namebase - ( make nfa relocatable )
+            [compile] literal   ( store nfa of word to be compiled )
+            compile namebase+
+        THEN
+    THEN
+; IMMEDIATE
+
+: ?LITERAL  ( n -- , do literal if compiling )
+    state @
+    IF [compile] literal
+    THEN
+;
+
+: 'c ( <name> -- xt , state sensitive ' )
+    ' ?literal
+; immediate
+
+variable if-debug
+
+decimal
+create msec-delay 10000 ,  ( default for SUN )
+: (MSEC) ( #msecs -- )
+    0
+    do  msec-delay @ 0
+        do loop
+    loop
+;
+
+defer msec
+' (msec) is msec
+
+: SHIFT ( val n -- val<<n )
+    dup 0<
+    IF negate arshift
+    ELSE lshift
+    THEN
+;
+
+
+variable rand-seed here rand-seed !
+: random ( -- random_number )
+    rand-seed @
+    31421 * 6927 +
+    65535 and dup rand-seed !
+;
+: choose  ( range -- random_number , in range )
+    random * -16 shift
+;
+
+: wchoose ( hi lo -- random_number )
+    tuck - choose +
+;
+
+
+\ sort top two items on stack.
+: 2sort ( a b -- a<b | b<a , largest on top of stack)
+    2dup >
+    if swap
+    then
+;
+
+\ sort top two items on stack.
+: -2sort ( a b -- a>b | b>a , smallest on top of stack)
+    2dup <
+    if swap
+    then
+;
+
+: barray  ( #bytes -- ) ( index -- addr )
+    create allot
+    does>  +
+;
+
+: warray  ( #words -- ) ( index -- addr )
+    create 2* allot
+    does> swap 2* +
+;
+
+: array  ( #cells -- ) ( index -- addr )
+    create cell* allot
+    does> swap cell* +
+;
+
+: .bin  ( n -- , print in binary )
+    base @ binary swap . base !
+;
+: .dec  ( n -- )
+    base @ decimal swap . base !
+;
+: .hex  ( n -- )
+    base @ hex swap . base !
+;
+
+: B->S ( c -- c' , sign extend byte )
+    dup $ 80 and
+    IF
+        $ FFFFFF00 or
+    ELSE
+        $ 000000FF and
+    THEN
+;
+: W->S ( 16bit-signed -- 32bit-signed )
+    dup $ 8000 and
+    if
+        $ FFFF0000 or
+    ELSE
+        $ 0000FFFF and
+    then
+;
+
+: WITHIN { n1 n2 n3 -- flag }
+    n2 n3 <=
+    IF
+        n2 n1 <=
+        n1 n3 <  AND
+    ELSE
+        n2 n1 <=
+        n1 n3 <  OR
+    THEN
+;
+
+: MOVE ( src dst num -- )
+    >r 2dup - 0<
+    IF
+        r> CMOVE>
+    ELSE
+        r> CMOVE
+    THEN
+;
+
+: ERASE ( caddr num -- )
+    dup 0>
+    IF
+        0 fill
+    ELSE
+        2drop
+    THEN
+;
+
+: BLANK ( addr u -- , set memory to blank )
+    DUP 0>
+    IF
+        BL FILL
+    ELSE
+        2DROP
+    THEN
+;
+
+\ Obsolete but included for CORE EXT word set.
+: QUERY REFILL DROP ;
+VARIABLE SPAN
+: EXPECT accept span ! ;
+: TIB source drop ;
+
+
+: UNUSED ( -- unused , dictionary space )
+    CODELIMIT HERE -
+;
+
+: MAP  ( -- , dump interesting dictionary info )
+    ." Code Segment" cr
+    ."    CODEBASE           = " codebase .hex cr
+    ."    HERE               = " here .hex cr
+    ."    CODELIMIT          = " codelimit .hex cr
+    ."    Compiled Code Size = " here codebase - . cr
+    ."    CODE-SIZE          = " code-size @ . cr
+    ."    Code Room UNUSED   = " UNUSED . cr
+    ." Name Segment" cr
+    ."    NAMEBASE           = " namebase .hex cr
+    ."    HEADERS-PTR @      = " headers-ptr @ .hex cr
+    ."    NAMELIMIT          = " namelimit .hex cr
+    ."    CONTEXT @          = " context @ .hex cr
+    ."    LATEST             = " latest .hex  ."  = " latest id. cr
+    ."    Compiled Name size = " headers-ptr @ namebase - . cr
+    ."    HEADERS-SIZE       = " headers-size @ . cr
+    ."    Name Room Left     = " namelimit headers-ptr @ - . cr
+;
+
+
+\ Search for substring S2 in S1
+: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }
+\ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr
+\ if true, s1 contains s2 at addr3 with cnt3 chars remaining
+\ if false, s3 = s1
+    addr1 -> addr3
+    cnt1 -> cnt3
+    cnt1 cnt2 < not
+    IF
+        cnt1 cnt2 - 1+ 0
+        DO
+            true -> flag
+            cnt2 0
+            ?DO
+                addr2 i chars + c@
+                addr1 i j + chars + c@ <> \ mismatch?
+                IF
+                    false -> flag
+                    LEAVE
+                THEN
+            LOOP
+            flag
+            IF
+                addr1 i chars + -> addr3
+                cnt1 i - -> cnt3
+                LEAVE
+            THEN
+        LOOP
+    THEN
+    addr3 cnt3 flag
+;
+

diff --git a/fth/numberio.fth b/fth/numberio.fth
index 0641c0b..833ca69 100644 (file)
--- a/fth/numberio.fth
+++ b/fth/numberio.fth
@@ -1,204 +1,204 @@
-\ @(#) numberio.fth 98/01/26 1.2\r
-\ numberio.fth\r
-\\r
-\ numeric conversion\r
-\ \r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-anew task-numberio.fth\r
-decimal\r
-\r
-\ ------------------------ INPUT -------------------------------\r
-\ Convert a single character to a number in the given base.\r
-: DIGIT   ( char base -- n true | char false )\r
-       >r\r
-\ convert lower to upper\r
-       dup ascii a < not\r
-       IF\r
-               ascii a - ascii A +\r
-       THEN\r
-\\r
-       dup dup ascii A 1- >\r
-       IF ascii A - ascii 9 + 1+\r
-       ELSE ( char char )\r
-               dup ascii 9 >\r
-               IF\r
-                       ( between 9 and A is bad )\r
-                       drop 0 ( trigger error below )\r
-               THEN\r
-       THEN\r
-       ascii 0 -\r
-       dup r> <\r
-       IF dup 1+ 0>\r
-               IF nip true\r
-               ELSE drop FALSE\r
-               THEN\r
-       ELSE drop FALSE\r
-       THEN\r
-;\r
-\r
-: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )\r
-       >r\r
-       BEGIN\r
-               r@ 0>    \ any characters left?\r
-               IF\r
-                       dup c@ base @\r
-                       digit ( ud1 c-addr , n true | char false )\r
-                       IF\r
-                               TRUE\r
-                       ELSE\r
-                               drop FALSE\r
-                       THEN\r
-               ELSE\r
-                       false\r
-               THEN\r
-       WHILE ( -- ud1 c-addr n  )\r
-               swap >r  ( -- ud1lo ud1hi n  )\r
-               swap  base @ ( -- ud1lo n ud1hi base  )\r
-               um* drop ( -- ud1lo n ud1hi*baselo  )\r
-               rot  base @ ( -- n ud1hi*baselo ud1lo base )\r
-               um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )\r
-               d+  ( -- ud2 )\r
-               r> 1+     \ increment char*\r
-               r> 1- >r  \ decrement count\r
-       REPEAT\r
-       r>\r
-;\r
-\r
-\ obsolete\r
-: CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )\r
-       256 >NUMBER DROP\r
-;\r
-\r
-0 constant NUM_TYPE_BAD\r
-1 constant NUM_TYPE_SINGLE\r
-2 constant NUM_TYPE_DOUBLE\r
-\r
-\ This is similar to the F83 NUMBER? except that it returns a number type\r
-\ and then either a single or double precision number.\r
-: ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )\r
-       dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?\r
-       \r
-\ prepare for >number\r
-       0 0 2swap ( 0 0 c-addr cnt )\r
-\r
-\ check for '-' at beginning, skip if present\r
-       over c@ ascii - = \ is it a '-'\r
-       dup >r            \ save flag\r
-       IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )\r
-       THEN\r
-\\r
-       >number dup 0=   \ convert as much as we can\r
-       IF\r
-               2drop    \ drop addr cnt\r
-               drop     \ drop hi part of num\r
-               r@       \ check flag to see if '-' sign used\r
-               IF  negate\r
-               THEN\r
-               NUM_TYPE_SINGLE\r
-       ELSE  ( -- d addr cnt )\r
-               1 = swap             \ if final character is '.' then double\r
-               c@ ascii . =  AND\r
-               IF\r
-                       r@      \ check flag to see if '-' sign used\r
-                       IF  dnegate\r
-                       THEN\r
-                       NUM_TYPE_DOUBLE\r
-               ELSE\r
-                       2drop\r
-                       NUM_TYPE_BAD\r
-               THEN\r
-       THEN\r
-       rdrop\r
-;\r
-\r
-: (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )\r
-       count ((number?))\r
-;\r
-\r
-' (number?) is number?\r
-\ hex\r
-\ 0sp c" xyz" (number?) .s\r
-\ 0sp c" 234" (number?) .s\r
-\ 0sp c" -234" (number?) .s\r
-\ 0sp c" 234." (number?) .s\r
-\ 0sp c" -234." (number?) .s\r
-\ 0sp c" 1234567855554444." (number?) .s\r
-\r
-\r
-\ ------------------------ OUTPUT ------------------------------\r
-\ Number output based on F83\r
-variable HLD    \ points to last character added \r
-\r
-: hold   ( char -- , add character to text representation)\r
-       -1 hld  +!\r
-       hld @  c!\r
-;\r
-: <#     ( -- , setup conversion )\r
-       pad hld !\r
-;\r
-: #>     ( d -- addr len , finish conversion )\r
-       2drop  hld @  pad  over -\r
-;\r
-: sign   ( n -- , add '-' if negative )\r
-       0<  if  ascii - hold  then\r
-;\r
-: #      ( d -- d , convert one digit )\r
-   base @  mu/mod rot 9 over <\r
-   IF  7 +\r
-   THEN\r
-   ascii 0 + hold\r
-;\r
-: #s     ( d -- d , convert remaining digits )\r
-       BEGIN  #  2dup or 0=\r
-       UNTIL\r
-;\r
-\r
-\r
-: (UD.) ( ud -- c-addr cnt )\r
-       <# #s #>\r
-;\r
-: UD.   ( ud -- , print unsigned double number )\r
-       (ud.)  type space\r
-;\r
-: UD.R  ( ud n -- )\r
-       >r  (ud.)  r> over - spaces type\r
-;\r
-: (D.)  ( d -- c-addr cnt )\r
-       tuck dabs <# #s rot sign #>\r
-;\r
-: D.    ( d -- )\r
-       (d.)  type space\r
-;\r
-: D.R   ( d n -- , right justified )\r
-       >r  (d.)  r>  over - spaces  type\r
-;\r
-\r
-: (U.)  ( u -- c-addr cnt )\r
-       0 (ud.)\r
-;\r
-: U.    ( u -- , print unsigned number )\r
-       0 ud.\r
-;\r
-: U.R   ( u n -- , print right justified )\r
-       >r  (u.)  r> over - spaces  type\r
-;\r
-: (.)   ( n -- c-addr cnt )\r
-       dup abs 0 <# #s rot sign #>\r
-;\r
-: .     ( n -- , print signed number)\r
-   (.)  type space\r
-;\r
-: .R    ( n l -- , print right justified)\r
-       >r  (.)  r> over - spaces type\r
-;\r
+\ @(#) numberio.fth 98/01/26 1.2
+\ numberio.fth
+\
+\ numeric conversion
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+anew task-numberio.fth
+decimal
+
+\ ------------------------ INPUT -------------------------------
+\ Convert a single character to a number in the given base.
+: DIGIT   ( char base -- n true | char false )
+    >r
+\ convert lower to upper
+    dup ascii a < not
+    IF
+        ascii a - ascii A +
+    THEN
+\
+    dup dup ascii A 1- >
+    IF ascii A - ascii 9 + 1+
+    ELSE ( char char )
+        dup ascii 9 >
+        IF
+            ( between 9 and A is bad )
+            drop 0 ( trigger error below )
+        THEN
+    THEN
+    ascii 0 -
+    dup r> <
+    IF dup 1+ 0>
+        IF nip true
+        ELSE drop FALSE
+        THEN
+    ELSE drop FALSE
+    THEN
+;
+
+: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )
+    >r
+    BEGIN
+        r@ 0>    \ any characters left?
+        IF
+            dup c@ base @
+            digit ( ud1 c-addr , n true | char false )
+            IF
+                TRUE
+            ELSE
+                drop FALSE
+            THEN
+        ELSE
+            false
+        THEN
+    WHILE ( -- ud1 c-addr n  )
+        swap >r  ( -- ud1lo ud1hi n  )
+        swap  base @ ( -- ud1lo n ud1hi base  )
+        um* drop ( -- ud1lo n ud1hi*baselo  )
+        rot  base @ ( -- n ud1hi*baselo ud1lo base )
+        um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )
+        d+  ( -- ud2 )
+        r> 1+     \ increment char*
+        r> 1- >r  \ decrement count
+    REPEAT
+    r>
+;
+
+\ obsolete
+: CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )
+    256 >NUMBER DROP
+;
+
+0 constant NUM_TYPE_BAD
+1 constant NUM_TYPE_SINGLE
+2 constant NUM_TYPE_DOUBLE
+
+\ This is similar to the F83 NUMBER? except that it returns a number type
+\ and then either a single or double precision number.
+: ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
+    dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?
+
+\ prepare for >number
+    0 0 2swap ( 0 0 c-addr cnt )
+
+\ check for '-' at beginning, skip if present
+    over c@ ascii - = \ is it a '-'
+    dup >r            \ save flag
+    IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )
+    THEN
+\
+    >number dup 0=   \ convert as much as we can
+    IF
+        2drop    \ drop addr cnt
+        drop     \ drop hi part of num
+        r@       \ check flag to see if '-' sign used
+        IF  negate
+        THEN
+        NUM_TYPE_SINGLE
+    ELSE  ( -- d addr cnt )
+        1 = swap             \ if final character is '.' then double
+        c@ ascii . =  AND
+        IF
+            r@      \ check flag to see if '-' sign used
+            IF  dnegate
+            THEN
+            NUM_TYPE_DOUBLE
+        ELSE
+            2drop
+            NUM_TYPE_BAD
+        THEN
+    THEN
+    rdrop
+;
+
+: (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )
+    count ((number?))
+;
+
+' (number?) is number?
+\ hex
+\ 0sp c" xyz" (number?) .s
+\ 0sp c" 234" (number?) .s
+\ 0sp c" -234" (number?) .s
+\ 0sp c" 234." (number?) .s
+\ 0sp c" -234." (number?) .s
+\ 0sp c" 1234567855554444." (number?) .s
+
+
+\ ------------------------ OUTPUT ------------------------------
+\ Number output based on F83
+variable HLD    \ points to last character added
+
+: hold   ( char -- , add character to text representation)
+    -1 hld  +!
+    hld @  c!
+;
+: <#     ( -- , setup conversion )
+    pad hld !
+;
+: #>     ( d -- addr len , finish conversion )
+    2drop  hld @  pad  over -
+;
+: sign   ( n -- , add '-' if negative )
+    0<  if  ascii - hold  then
+;
+: #      ( d -- d , convert one digit )
+   base @  mu/mod rot 9 over <
+   IF  7 +
+   THEN
+   ascii 0 + hold
+;
+: #s     ( d -- d , convert remaining digits )
+    BEGIN  #  2dup or 0=
+    UNTIL
+;
+
+
+: (UD.) ( ud -- c-addr cnt )
+    <# #s #>
+;
+: UD.   ( ud -- , print unsigned double number )
+    (ud.)  type space
+;
+: UD.R  ( ud n -- )
+    >r  (ud.)  r> over - spaces type
+;
+: (D.)  ( d -- c-addr cnt )
+    tuck dabs <# #s rot sign #>
+;
+: D.    ( d -- )
+    (d.)  type space
+;
+: D.R   ( d n -- , right justified )
+    >r  (d.)  r>  over - spaces  type
+;
+
+: (U.)  ( u -- c-addr cnt )
+    0 (ud.)
+;
+: U.    ( u -- , print unsigned number )
+    0 ud.
+;
+: U.R   ( u n -- , print right justified )
+    >r  (u.)  r> over - spaces  type
+;
+: (.)   ( n -- c-addr cnt )
+    dup abs 0 <# #s rot sign #>
+;
+: .     ( n -- , print signed number)
+   (.)  type space
+;
+: .R    ( n l -- , print right justified)
+    >r  (.)  r> over - spaces type
+;

diff --git a/fth/private.fth b/fth/private.fth
index 782ec1c..d7d465d 100644 (file)
--- a/fth/private.fth
+++ b/fth/private.fth
@@ -1,48 +1,48 @@
-\ @(#) private.fth 98/01/26 1.2\r
-\ PRIVATIZE\r
-\\r
-\ Privatize words that are only needed within the file\r
-\ and do not need to be exported.\r
-\\r
-\ Usage:\r
-\    PRIVATE{\r
-\    : FOO ;  \ Everything between PRIVATE{ and }PRIVATE will become private.\r
-\    : MOO ;\r
-\    }PRIVATE\r
-\    : GOO   foo moo ;  \ can use foo and moo\r
-\    PRIVATIZE          \ smudge foo and moo\r
-\    ' foo              \ will fail\r
-\\r
-\ Copyright 1996 Phil Burk\r
-\\r
-\ 19970701 PLB Use unsigned compares for machines with "negative" addresses.\r
-\r
-anew task-private.fth\r
-\r
-variable private-start\r
-variable private-stop\r
-$ 20 constant FLAG_SMUDGE\r
-\r
-: PRIVATE{\r
-       latest private-start !\r
-       0 private-stop !\r
-;\r
-: }PRIVATE\r
-       private-stop @ 0= not abort" Extra }PRIVATE"\r
-       latest private-stop !\r
-;\r
-: PRIVATIZE  ( -- , smudge all words between PRIVATE{ and }PRIVATE )\r
-       private-start @ 0= abort" Missing PRIVATE{"\r
-       private-stop @ 0= abort" Missing }PRIVATE"\r
-       private-stop @\r
-       BEGIN\r
-               dup private-start @ u>    \ 19970701\r
-       WHILE\r
-\              ." Smudge " dup id. cr\r
-               dup c@ flag_smudge or over c!\r
-               prevname\r
-       REPEAT\r
-       drop\r
-       0 private-start !\r
-       0 private-stop !\r
-;\r
+\ @(#) private.fth 98/01/26 1.2
+\ PRIVATIZE
+\
+\ Privatize words that are only needed within the file
+\ and do not need to be exported.
+\
+\ Usage:
+\    PRIVATE{
+\    : FOO ;  \ Everything between PRIVATE{ and }PRIVATE will become private.
+\    : MOO ;
+\    }PRIVATE
+\    : GOO   foo moo ;  \ can use foo and moo
+\    PRIVATIZE          \ smudge foo and moo
+\    ' foo              \ will fail
+\
+\ Copyright 1996 Phil Burk
+\
+\ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
+
+anew task-private.fth
+
+variable private-start
+variable private-stop
+$ 20 constant FLAG_SMUDGE
+
+: PRIVATE{
+    latest private-start !
+    0 private-stop !
+;
+: }PRIVATE
+    private-stop @ 0= not abort" Extra }PRIVATE"
+    latest private-stop !
+;
+: PRIVATIZE  ( -- , smudge all words between PRIVATE{ and }PRIVATE )
+    private-start @ 0= abort" Missing PRIVATE{"
+    private-stop @ 0= abort" Missing }PRIVATE"
+    private-stop @
+    BEGIN
+        dup private-start @ u>    \ 19970701
+    WHILE
+\       ." Smudge " dup id. cr
+        dup c@ flag_smudge or over c!
+        prevname
+    REPEAT
+    drop
+    0 private-start !
+    0 private-stop !
+;

diff --git a/fth/savedicd.fth b/fth/savedicd.fth
index 290b01d..99a5e33 100644 (file)
--- a/fth/savedicd.fth
+++ b/fth/savedicd.fth
@@ -1,177 +1,177 @@
-\ @(#) savedicd.fth 98/01/26 1.2\r
-\ Save dictionary as data table.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1987 Phil Burk\r
-\ All Rights Reserved.\r
-\\r
-\ 970311 PLB Fixed problem with calling SDAD when in HEX mode.\r
-\ 20010606 PLB Fixed AUTO.INIT , started with ';' !!\r
-\r
-decimal\r
-ANEW TASK-SAVE_DIC_AS_DATA\r
-\r
-\ !!! set to 4 for minimally sized dictionary to prevent DIAB\r
-\ compiler from crashing!  Allocate more space in pForth.\r
-4 constant SDAD_NAMES_EXTRA   \ space for additional names\r
-4 constant SDAD_CODE_EXTRA    \ space for additional names\r
-\r
-\ buffer the file I/O for better performance\r
-256 constant SDAD_BUFFER_SIZE\r
-create SDAD-BUFFER SDAD_BUFFER_SIZE allot\r
-variable SDAD-BUFFER-INDEX\r
-variable SDAD-BUFFER-FID\r
-               0 SDAD-BUFFER-FID !\r
-\r
-: SDAD.FLUSH  ( -- ior )\r
-       sdad-buffer sdad-buffer-index @  \ data\r
-\ 2dup type\r
-       sdad-buffer-fid @  write-file\r
-       0 sdad-buffer-index !\r
-;\r
-\r
-: SDAD.EMIT  ( char -- )\r
-    sdad-buffer-index @  sdad_buffer_size >=\r
-    IF\r
-       sdad.flush abort" SDAD.FLUSH failed!"\r
-    THEN\r
-\\r
-    sdad-buffer sdad-buffer-index @ + c!\r
-    1 sdad-buffer-index +!\r
-;\r
-\r
-: SDAD.TYPE  ( c-addr cnt -- )\r
-       0 DO\r
-               dup c@ sdad.emit    \ char to buffer\r
-               1+   \ advance char pointer\r
-       LOOP\r
-       drop\r
-;\r
-\r
-: $SDAD.LINE  ( $addr -- )\r
-       count sdad.type\r
-       EOL sdad.emit\r
-;\r
-\r
-: (U8.)  ( u -- a l , unsigned conversion, at least 8 digits )\r
-       0 <#  # # # #  # # # #S #>\r
-;\r
-: (U2.)  ( u -- a l , unsigned conversion, at least 2 digits )\r
-       0 <#  # #S #>\r
-;\r
-\r
-: SDAD.CLOSE ( -- )\r
-       SDAD-BUFFER-FID @ ?dup\r
-       IF\r
-               sdad.flush abort" SDAD.FLUSH failed!"\r
-               close-file drop\r
-               0 SDAD-BUFFER-FID !\r
-       THEN\r
-;\r
-\r
-: SDAD.OPEN  ( -- ior, open file )\r
-       sdad.close\r
-       s" pfdicdat.h" r/w create-file dup >r\r
-       IF\r
-               drop ." Could not create file pfdicdat.h" cr\r
-       ELSE\r
-               SDAD-BUFFER-FID !\r
-       THEN\r
-       r>\r
-;\r
-\r
-: SDAD.DUMP.HEX  { val -- }\r
-       base @ >r hex\r
-       s" 0x" sdad.type\r
-       val (u8.) sdad.type\r
-       r> base !\r
-;\r
-: SDAD.DUMP.HEX, \r
-       s"    " sdad.type\r
-       sdad.dump.hex\r
-       ascii , sdad.emit\r
-;\r
-\r
-: SDAD.DUMP.HEX.BYTE  { val -- }\r
-       base @ >r hex\r
-       s" 0x" sdad.type\r
-       val (u2.) sdad.type\r
-       r> base !\r
-;\r
-: SDAD.DUMP.HEX.BYTE,\r
-       sdad.dump.hex.byte\r
-       ascii , sdad.emit\r
-;\r
-\r
-: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- }\r
-       end-address start-address - -> num-bytes\r
-       num-bytes 0\r
-       ?DO\r
-               i $ 7FF and 0= IF ." 0x" i .hex cr THEN   \ progress report\r
-               i 15 and 0=\r
-               IF\r
-                        \r
-                        EOL sdad.emit\r
-                        s" /* " sdad.type\r
-                        i sdad.dump.hex\r
-                        s" : */ " sdad.type\r
-               THEN   \ 16 bytes per line, print offset\r
-               start-address   i + c@\r
-               sdad.dump.hex.byte,\r
-       LOOP\r
-\\r
-       num-zeros 0\r
-       ?DO\r
-               i $ 7FF and 0= IF i . cr THEN   \ progress report\r
-               i 15 and 0= IF EOL sdad.emit THEN   \ 15 numbers per line\r
-               0 sdad.dump.hex.byte,\r
-       LOOP\r
-;\r
-\r
-: SDAD.DEFINE  { $name val -- }\r
-       s" #define " sdad.type\r
-       $name  count sdad.type\r
-       s"   (" sdad.type\r
-       val sdad.dump.hex\r
-       c" )" $sdad.line\r
-;\r
-\r
-: IS.LITTLE.ENDIAN?  ( -- flag , is Forth in Little Endian mode? )\r
-       1 pad !\r
-       pad c@\r
-;\r
-       \r
-: SDAD   { | fid -- }\r
-       sdad.open abort" sdad.open failed!"\r
-\ Write headers.\r
-       c" /* This file generated by the Forth command SDAD */" $sdad.line\r
-\r
-       c" HEADERPTR" headers-ptr @ namebase - sdad.define\r
-       c" RELCONTEXT" context @ namebase - sdad.define\r
-       c" CODEPTR" here codebase - sdad.define\r
-       c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define\r
-       \r
-." Saving Names" cr\r
-       s" static const uint8_t MinDicNames[] = {" sdad.type\r
-       namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data\r
-       EOL sdad.emit\r
-       c" };" $sdad.line\r
-       \r
-." Saving Code" cr\r
-       s" static const uint8_t MinDicCode[] = {" sdad.type\r
-       codebase here SDAD_CODE_EXTRA sdad.dump.data\r
-       EOL sdad.emit\r
-       c" };" $sdad.line\r
-\r
-       sdad.close\r
-;\r
-\r
-if.forgotten sdad.close\r
-\r
-: AUTO.INIT ( -- , init at launch )\r
-       auto.init \ daisy chain initialization\r
-       0 SDAD-BUFFER-FID !\r
-       0 SDAD-BUFFER-INDEX !\r
-;\r
-\r
-." Enter: SDAD" cr\r
+\ @(#) savedicd.fth 98/01/26 1.2
+\ Save dictionary as data table.
+\
+\ Author: Phil Burk
+\ Copyright 1987 Phil Burk
+\ All Rights Reserved.
+\
+\ 970311 PLB Fixed problem with calling SDAD when in HEX mode.
+\ 20010606 PLB Fixed AUTO.INIT , started with ';' !!
+
+decimal
+ANEW TASK-SAVE_DIC_AS_DATA
+
+\ !!! set to 4 for minimally sized dictionary to prevent DIAB
+\ compiler from crashing!  Allocate more space in pForth.
+4 constant SDAD_NAMES_EXTRA   \ space for additional names
+4 constant SDAD_CODE_EXTRA    \ space for additional names
+
+\ buffer the file I/O for better performance
+256 constant SDAD_BUFFER_SIZE
+create SDAD-BUFFER SDAD_BUFFER_SIZE allot
+variable SDAD-BUFFER-INDEX
+variable SDAD-BUFFER-FID
+        0 SDAD-BUFFER-FID !
+
+: SDAD.FLUSH  ( -- ior )
+    sdad-buffer sdad-buffer-index @  \ data
+\ 2dup type
+    sdad-buffer-fid @  write-file
+    0 sdad-buffer-index !
+;
+
+: SDAD.EMIT  ( char -- )
+    sdad-buffer-index @  sdad_buffer_size >=
+    IF
+        sdad.flush abort" SDAD.FLUSH failed!"
+    THEN
+\
+    sdad-buffer sdad-buffer-index @ + c!
+    1 sdad-buffer-index +!
+;
+
+: SDAD.TYPE  ( c-addr cnt -- )
+    0 DO
+        dup c@ sdad.emit    \ char to buffer
+        1+   \ advance char pointer
+    LOOP
+    drop
+;
+
+: $SDAD.LINE  ( $addr -- )
+    count sdad.type
+    EOL sdad.emit
+;
+
+: (U8.)  ( u -- a l , unsigned conversion, at least 8 digits )
+    0 <#  # # # #  # # # #S #>
+;
+: (U2.)  ( u -- a l , unsigned conversion, at least 2 digits )
+    0 <#  # #S #>
+;
+
+: SDAD.CLOSE ( -- )
+    SDAD-BUFFER-FID @ ?dup
+    IF
+        sdad.flush abort" SDAD.FLUSH failed!"
+        close-file drop
+        0 SDAD-BUFFER-FID !
+    THEN
+;
+
+: SDAD.OPEN  ( -- ior, open file )
+    sdad.close
+    s" pfdicdat.h" r/w create-file dup >r
+    IF
+        drop ." Could not create file pfdicdat.h" cr
+    ELSE
+        SDAD-BUFFER-FID !
+    THEN
+    r>
+;
+
+: SDAD.DUMP.HEX  { val -- }
+    base @ >r hex
+    s" 0x" sdad.type
+    val (u8.) sdad.type
+    r> base !
+;
+: SDAD.DUMP.HEX,
+    s"    " sdad.type
+    sdad.dump.hex
+    ascii , sdad.emit
+;
+
+: SDAD.DUMP.HEX.BYTE  { val -- }
+    base @ >r hex
+    s" 0x" sdad.type
+    val (u2.) sdad.type
+    r> base !
+;
+: SDAD.DUMP.HEX.BYTE,
+    sdad.dump.hex.byte
+    ascii , sdad.emit
+;
+
+: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- }
+    end-address start-address - -> num-bytes
+    num-bytes 0
+    ?DO
+        i $ 7FF and 0= IF ." 0x" i .hex cr THEN   \ progress report
+        i 15 and 0=
+        IF
+
+             EOL sdad.emit
+             s" /* " sdad.type
+             i sdad.dump.hex
+             s" : */ " sdad.type
+        THEN   \ 16 bytes per line, print offset
+        start-address   i + c@
+        sdad.dump.hex.byte,
+    LOOP
+\
+    num-zeros 0
+    ?DO
+        i $ 7FF and 0= IF i . cr THEN   \ progress report
+        i 15 and 0= IF EOL sdad.emit THEN   \ 15 numbers per line
+        0 sdad.dump.hex.byte,
+    LOOP
+;
+
+: SDAD.DEFINE  { $name val -- }
+    s" #define " sdad.type
+    $name  count sdad.type
+    s"   (" sdad.type
+    val sdad.dump.hex
+    c" )" $sdad.line
+;
+
+: IS.LITTLE.ENDIAN?  ( -- flag , is Forth in Little Endian mode? )
+    1 pad !
+    pad c@
+;
+
+: SDAD   { | fid -- }
+    sdad.open abort" sdad.open failed!"
+\ Write headers.
+    c" /* This file generated by the Forth command SDAD */" $sdad.line
+
+    c" HEADERPTR" headers-ptr @ namebase - sdad.define
+    c" RELCONTEXT" context @ namebase - sdad.define
+    c" CODEPTR" here codebase - sdad.define
+    c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define
+
+." Saving Names" cr
+    s" static const uint8_t MinDicNames[] = {" sdad.type
+    namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data
+    EOL sdad.emit
+    c" };" $sdad.line
+
+." Saving Code" cr
+    s" static const uint8_t MinDicCode[] = {" sdad.type
+    codebase here SDAD_CODE_EXTRA sdad.dump.data
+    EOL sdad.emit
+    c" };" $sdad.line
+
+    sdad.close
+;
+
+if.forgotten sdad.close
+
+: AUTO.INIT ( -- , init at launch )
+    auto.init \ daisy chain initialization
+    0 SDAD-BUFFER-FID !
+    0 SDAD-BUFFER-INDEX !
+;
+
+." Enter: SDAD" cr

diff --git a/fth/see.fth b/fth/see.fth
index d0765d1..760b034 100644 (file)
--- a/fth/see.fth
+++ b/fth/see.fth
@@ -1,218 +1,218 @@
-\ @(#) see.fth 98/01/26 1.4\r
-\ SEE ( <name> -- , disassemble pForth word )\r
-\\r
-\ Copyright 1996 Phil Burk\r
-\r
-' file? >code rfence a!\r
-\r
-anew task-see.fth\r
-\r
-: .XT ( xt -- , print execution tokens name )\r
-       >name\r
-       dup c@ flag_immediate and\r
-       IF\r
-               ." POSTPONE "\r
-       THEN\r
-       id. space\r
-;\r
-\r
-\ dictionary may be defined as byte code or cell code\r
-0 constant BYTE_CODE\r
-\r
-BYTE_CODE [IF]\r
-       : CODE@ ( addr -- xt , fetch from code space )   C@ ;\r
-       1 constant CODE_CELL\r
-       .( BYTE_CODE not implemented) abort\r
-[ELSE]\r
-       : CODE@ ( addr -- xt , fetch from code space )   @ ;\r
-       CELL constant CODE_CELL\r
-[THEN]\r
-\r
-private{\r
-\r
-0 value see_level  \ level of conditional imdentation\r
-0 value see_addr   \ address of next token\r
-0 value see_out\r
-\r
-: SEE.INDENT.BY ( -- n )\r
-       see_level 1+ 1 max 4 *\r
-;\r
-\r
-: SEE.CR\r
-       >newline\r
-       see_addr ." ( ".hex ." )"\r
-       see.indent.by spaces\r
-       0 -> see_out\r
-;\r
-: SEE.NEWLINE\r
-       see_out 0>\r
-       IF see.cr\r
-       THEN\r
-;\r
-: SEE.CR?\r
-       see_out 6 >\r
-       IF\r
-               see.newline\r
-       THEN\r
-;\r
-: SEE.OUT+\r
-       1 +-> see_out\r
-;\r
-\r
-: SEE.ADVANCE\r
-       code_cell +-> see_addr\r
-;\r
-: SEE.GET.INLINE ( -- n )\r
-       see_addr @\r
-;\r
-\r
-: SEE.GET.TARGET  ( -- branch-target-addr )\r
-       see_addr @ see_addr +\r
-;\r
-\r
-: SEE.SHOW.LIT ( -- )\r
-       see.get.inline .\r
-       see.advance\r
-       see.out+\r
-;\r
-\r
-exists? F* [IF]\r
-: SEE.SHOW.FLIT ( -- )\r
-       see_addr f@ f.\r
-       1 floats +-> see_addr\r
-       see.out+\r
-;\r
-[THEN]\r
-\r
-: SEE.SHOW.ALIT ( -- )\r
-       see.get.inline >name id. space\r
-       see.advance\r
-       see.out+\r
-;\r
-\r
-: SEE.SHOW.STRING ( -- )\r
-       see_addr count 2dup + aligned -> see_addr type\r
-       see.out+\r
-;\r
-: SEE.SHOW.TARGET ( -- )\r
-       see.get.target .hex see.advance\r
-;\r
-\r
-: SEE.BRANCH ( -- addr | , handle branch )\r
-       -1 +-> see_level\r
-       see.newline \r
-       see.get.inline  0>\r
-       IF  \ forward branch\r
-               ." ELSE "\r
-               see.get.target \ calculate address of target\r
-               1 +-> see_level\r
-               nip \ remove old address for THEN\r
-       ELSE\r
-               ." REPEAT " see.get.target .hex\r
-               drop \ remove old address for THEN\r
-       THEN\r
-       see.advance\r
-       see.cr\r
-;\r
-\r
-: SEE.0BRANCH ( -- addr | , handle 0branch )\r
-       see.newline \r
-       see.get.inline 0>\r
-       IF  \ forward branch\r
-               ." IF or WHILE "\r
-               see.get.target \ calculate adress of target\r
-               1 +-> see_level\r
-       ELSE\r
-               ." UNTIL=>" see.get.target .hex\r
-       THEN\r
-       see.advance\r
-       see.cr\r
-;\r
-\r
-: SEE.XT  { xt -- }\r
-       xt\r
-       CASE\r
-               0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0  -> see_addr THEN ENDOF\r
-               ['] (LITERAL) OF see.show.lit ENDOF\r
-               ['] (ALITERAL) OF see.show.alit ENDOF\r
-[ exists? (FLITERAL) [IF] ]\r
-               ['] (FLITERAL) OF see.show.flit ENDOF\r
-[ [THEN] ]\r
-               ['] BRANCH    OF see.branch ENDOF\r
-               ['] 0BRANCH   OF see.0branch ENDOF\r
-               ['] (LOOP)    OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr  ENDOF\r
-               ['] (+LOOP)   OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr  ENDOF\r
-               ['] (DO)      OF see.newline ." DO" 1 +-> see_level see.cr ENDOF\r
-               ['] (?DO)     OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF\r
-               ['] (.") OF .' ." ' see.show.string .' " ' ENDOF\r
-               ['] (C") OF .' C" ' see.show.string .' " ' ENDOF\r
-               ['] (S") OF .' S" ' see.show.string .' " ' ENDOF\r
-\r
-               see.cr? xt .xt see.out+\r
-       ENDCASE\r
-;\r
-\r
-: (SEE) { cfa | xt  -- }\r
-       0 -> see_level\r
-       cfa -> see_addr\r
-       see.cr\r
-       0 \ fake address for THEN handler\r
-       BEGIN\r
-               see_addr code@ -> xt\r
-               BEGIN\r
-                       dup see_addr ( >newline .s ) =\r
-               WHILE\r
-                       -1 +-> see_level see.newline \r
-                       ." THEN " see.cr\r
-                       drop\r
-               REPEAT\r
-               CODE_CELL +-> see_addr\r
-               xt see.xt\r
-               see_addr 0=\r
-       UNTIL\r
-       cr\r
-       0= not abort" SEE conditional analyser nesting failed!"\r
-;\r
-\r
-}PRIVATE\r
-\r
-: SEE  ( <name> -- , disassemble )\r
-       '\r
-       dup ['] FIRST_COLON >\r
-       IF\r
-               >code (see)\r
-       ELSE\r
-               >name id.\r
-               ."  is primitive defined in 'C' kernel." cr\r
-       THEN\r
-;\r
-\r
-PRIVATIZE\r
-\r
-0 [IF]\r
-\r
-: SEE.JOKE\r
-       dup swap drop\r
-;\r
-\r
-: SEE.IF\r
-       IF\r
-               ." hello" cr\r
-       ELSE\r
-               ." bye" cr\r
-       THEN\r
-       see.joke\r
-;\r
-: SEE.DO\r
-       4 0\r
-       DO\r
-               i . cr\r
-       LOOP\r
-;\r
-: SEE."\r
-       ." Here are some strings." cr\r
-       c" Forth string." count type cr\r
-       s" Addr/Cnt string" type cr\r
-;\r
-\r
-[THEN]\r
+\ @(#) see.fth 98/01/26 1.4
+\ SEE ( <name> -- , disassemble pForth word )
+\
+\ Copyright 1996 Phil Burk
+
+' file? >code rfence a!
+
+anew task-see.fth
+
+: .XT ( xt -- , print execution tokens name )
+    >name
+    dup c@ flag_immediate and
+    IF
+        ." POSTPONE "
+    THEN
+    id. space
+;
+
+\ dictionary may be defined as byte code or cell code
+0 constant BYTE_CODE
+
+BYTE_CODE [IF]
+    : CODE@ ( addr -- xt , fetch from code space )   C@ ;
+    1 constant CODE_CELL
+    .( BYTE_CODE not implemented) abort
+[ELSE]
+    : CODE@ ( addr -- xt , fetch from code space )   @ ;
+    CELL constant CODE_CELL
+[THEN]
+
+private{
+
+0 value see_level  \ level of conditional imdentation
+0 value see_addr   \ address of next token
+0 value see_out
+
+: SEE.INDENT.BY ( -- n )
+    see_level 1+ 1 max 4 *
+;
+
+: SEE.CR
+    >newline
+    see_addr ." ( ".hex ." )"
+    see.indent.by spaces
+    0 -> see_out
+;
+: SEE.NEWLINE
+    see_out 0>
+    IF see.cr
+    THEN
+;
+: SEE.CR?
+    see_out 6 >
+    IF
+        see.newline
+    THEN
+;
+: SEE.OUT+
+    1 +-> see_out
+;
+
+: SEE.ADVANCE
+    code_cell +-> see_addr
+;
+: SEE.GET.INLINE ( -- n )
+    see_addr @
+;
+
+: SEE.GET.TARGET  ( -- branch-target-addr )
+    see_addr @ see_addr +
+;
+
+: SEE.SHOW.LIT ( -- )
+    see.get.inline .
+    see.advance
+    see.out+
+;
+
+exists? F* [IF]
+: SEE.SHOW.FLIT ( -- )
+    see_addr f@ f.
+    1 floats +-> see_addr
+    see.out+
+;
+[THEN]
+
+: SEE.SHOW.ALIT ( -- )
+    see.get.inline >name id. space
+    see.advance
+    see.out+
+;
+
+: SEE.SHOW.STRING ( -- )
+    see_addr count 2dup + aligned -> see_addr type
+    see.out+
+;
+: SEE.SHOW.TARGET ( -- )
+    see.get.target .hex see.advance
+;
+
+: SEE.BRANCH ( -- addr | , handle branch )
+    -1 +-> see_level
+    see.newline
+    see.get.inline  0>
+    IF  \ forward branch
+        ." ELSE "
+        see.get.target \ calculate address of target
+        1 +-> see_level
+        nip \ remove old address for THEN
+    ELSE
+        ." REPEAT " see.get.target .hex
+        drop \ remove old address for THEN
+    THEN
+    see.advance
+    see.cr
+;
+
+: SEE.0BRANCH ( -- addr | , handle 0branch )
+    see.newline
+    see.get.inline 0>
+    IF  \ forward branch
+        ." IF or WHILE "
+        see.get.target \ calculate adress of target
+        1 +-> see_level
+    ELSE
+        ." UNTIL=>" see.get.target .hex
+    THEN
+    see.advance
+    see.cr
+;
+
+: SEE.XT  { xt -- }
+    xt
+    CASE
+        0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0  -> see_addr THEN ENDOF
+        ['] (LITERAL) OF see.show.lit ENDOF
+        ['] (ALITERAL) OF see.show.alit ENDOF
+[ exists? (FLITERAL) [IF] ]
+        ['] (FLITERAL) OF see.show.flit ENDOF
+[ [THEN] ]
+        ['] BRANCH    OF see.branch ENDOF
+        ['] 0BRANCH   OF see.0branch ENDOF
+        ['] (LOOP)    OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr  ENDOF
+        ['] (+LOOP)   OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr  ENDOF
+        ['] (DO)      OF see.newline ." DO" 1 +-> see_level see.cr ENDOF
+        ['] (?DO)     OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF
+        ['] (.") OF .' ." ' see.show.string .' " ' ENDOF
+        ['] (C") OF .' C" ' see.show.string .' " ' ENDOF
+        ['] (S") OF .' S" ' see.show.string .' " ' ENDOF
+
+        see.cr? xt .xt see.out+
+    ENDCASE
+;
+
+: (SEE) { cfa | xt  -- }
+    0 -> see_level
+    cfa -> see_addr
+    see.cr
+    0 \ fake address for THEN handler
+    BEGIN
+        see_addr code@ -> xt
+        BEGIN
+            dup see_addr ( >newline .s ) =
+        WHILE
+            -1 +-> see_level see.newline
+            ." THEN " see.cr
+            drop
+        REPEAT
+        CODE_CELL +-> see_addr
+        xt see.xt
+        see_addr 0=
+    UNTIL
+    cr
+    0= not abort" SEE conditional analyser nesting failed!"
+;
+
+}PRIVATE
+
+: SEE  ( <name> -- , disassemble )
+    '
+    dup ['] FIRST_COLON >
+    IF
+        >code (see)
+    ELSE
+        >name id.
+        ."  is primitive defined in 'C' kernel." cr
+    THEN
+;
+
+PRIVATIZE
+
+0 [IF]
+
+: SEE.JOKE
+    dup swap drop
+;
+
+: SEE.IF
+    IF
+        ." hello" cr
+    ELSE
+        ." bye" cr
+    THEN
+    see.joke
+;
+: SEE.DO
+    4 0
+    DO
+        i . cr
+    LOOP
+;
+: SEE."
+    ." Here are some strings." cr
+    c" Forth string." count type cr
+    s" Addr/Cnt string" type cr
+;
+
+[THEN]

diff --git a/fth/siev.fth b/fth/siev.fth
index 7cebf51..e595955 100644 (file)
--- a/fth/siev.fth
+++ b/fth/siev.fth
@@ -1,31 +1,31 @@
-\ #! /usr/stud/paysan/bin/forth\r
-\r
-DECIMAL\r
-\ : SECS TIME&DATE  SWAP 60 * + SWAP 3600 * +  NIP NIP NIP ;\r
-CREATE FLAGS 8190 ALLOT\r
-variable eflag\r
-\ FLAGS 8190 + CONSTANT EFLAG\r
-\r
-\ use secondary fill like pForth   !!!\r
-: FILL { caddr num charval -- }\r
-       num 0\r
-       ?DO\r
-               charval caddr i + c!\r
-       LOOP\r
-;\r
-\r
-: PRIMES  ( -- n )  FLAGS 8190 1 FILL  0 3  EFLAG @ FLAGS\r
-  DO   I C@\r
-       IF  DUP I + DUP EFLAG @ <\r
-           IF    EFLAG @ SWAP\r
-                 DO  0 I C! DUP  +LOOP\r
-           ELSE  DROP  THEN  SWAP 1+ SWAP\r
-           THEN  2 +\r
-       LOOP  DROP ;\r
-\r
-: BENCHMARK  0 100 0 DO  PRIMES NIP  LOOP ;                      \ !!! ONLY 100\r
-\ SECS BENCHMARK . SECS SWAP - CR . .( secs)\r
-: main \r
-       flags 8190 + eflag !\r
-       benchmark ( . ) drop\r
-;\r
+\ #! /usr/stud/paysan/bin/forth
+
+DECIMAL
+\ : SECS TIME&DATE  SWAP 60 * + SWAP 3600 * +  NIP NIP NIP ;
+CREATE FLAGS 8190 ALLOT
+variable eflag
+\ FLAGS 8190 + CONSTANT EFLAG
+
+\ use secondary fill like pForth   !!!
+: FILL { caddr num charval -- }
+    num 0
+    ?DO
+        charval caddr i + c!
+    LOOP
+;
+
+: PRIMES  ( -- n )  FLAGS 8190 1 FILL  0 3  EFLAG @ FLAGS
+  DO   I C@
+       IF  DUP I + DUP EFLAG @ <
+           IF    EFLAG @ SWAP
+                 DO  0 I C! DUP  +LOOP
+           ELSE  DROP  THEN  SWAP 1+ SWAP
+           THEN  2 +
+       LOOP  DROP ;
+
+: BENCHMARK  0 100 0 DO  PRIMES NIP  LOOP ;           \ !!! ONLY 100
+\ SECS BENCHMARK . SECS SWAP - CR . .( secs)
+: main
+    flags 8190 + eflag !
+    benchmark ( . ) drop
+;

diff --git a/fth/smart_if.fth b/fth/smart_if.fth
index 65077c0..2234e18 100644 (file)
--- a/fth/smart_if.fth
+++ b/fth/smart_if.fth
@@ -1,57 +1,57 @@
-\ @(#) smart_if.fth 98/01/26 1.2\r
-\ Smart Conditionals\r
-\ Allow use of if, do, begin, etc.outside of colon definitions.\r
-\\r
-\ Thanks to Mitch Bradley for the idea.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-anew task-smart_if.fth\r
-\r
-variable SMIF-XT    \ execution token for conditional code\r
-variable SMIF-DEPTH \ depth of nested conditionals\r
-\r
-: SMIF{   ( -- , if executing, start compiling, setup depth )\r
-       state @ 0=\r
-       IF\r
-               :noname smif-xt !\r
-               1 smif-depth !\r
-       ELSE\r
-               1 smif-depth +!\r
-       THEN\r
-;\r
-\r
-: }SMIF  ( -- , unnest, stop compiling, execute code and forget )\r
-       smif-xt @\r
-       IF\r
-               -1 smif-depth +!\r
-               smif-depth @ 0 <=\r
-               IF\r
-                       postpone ;             \ stop compiling\r
-                       smif-xt @ execute      \ execute conditional code\r
-                       smif-xt @ >code dp !   \ forget conditional code\r
-                       0 smif-xt !   \ clear so we don't mess up later\r
-               THEN\r
-       THEN\r
-;\r
-               \r
-\ redefine conditionals to use smart mode\r
-: IF      smif{   postpone if     ; immediate\r
-: DO      smif{   postpone do     ; immediate\r
-: ?DO     smif{   postpone ?do    ; immediate\r
-: BEGIN   smif{   postpone begin  ; immediate\r
-: THEN    postpone then    }smif  ; immediate\r
-: REPEAT  postpone repeat  }smif  ; immediate\r
-: UNTIL   postpone until   }smif  ; immediate\r
-: LOOP    postpone loop    }smif  ; immediate\r
-: +LOOP   postpone +loop   }smif  ; immediate\r
+\ @(#) smart_if.fth 98/01/26 1.2
+\ Smart Conditionals
+\ Allow use of if, do, begin, etc.outside of colon definitions.
+\
+\ Thanks to Mitch Bradley for the idea.
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+anew task-smart_if.fth
+
+variable SMIF-XT    \ execution token for conditional code
+variable SMIF-DEPTH \ depth of nested conditionals
+
+: SMIF{   ( -- , if executing, start compiling, setup depth )
+    state @ 0=
+    IF
+        :noname smif-xt !
+        1 smif-depth !
+    ELSE
+        1 smif-depth +!
+    THEN
+;
+
+: }SMIF  ( -- , unnest, stop compiling, execute code and forget )
+    smif-xt @
+    IF
+        -1 smif-depth +!
+        smif-depth @ 0 <=
+        IF
+            postpone ;             \ stop compiling
+            smif-xt @ execute      \ execute conditional code
+            smif-xt @ >code dp !   \ forget conditional code
+            0 smif-xt !   \ clear so we don't mess up later
+        THEN
+    THEN
+;
+
+\ redefine conditionals to use smart mode
+: IF      smif{   postpone if     ; immediate
+: DO      smif{   postpone do     ; immediate
+: ?DO     smif{   postpone ?do    ; immediate
+: BEGIN   smif{   postpone begin  ; immediate
+: THEN    postpone then    }smif  ; immediate
+: REPEAT  postpone repeat  }smif  ; immediate
+: UNTIL   postpone until   }smif  ; immediate
+: LOOP    postpone loop    }smif  ; immediate
+: +LOOP   postpone +loop   }smif  ; immediate

diff --git a/fth/strings.fth b/fth/strings.fth
index dc998ad..c32c538 100644 (file)
--- a/fth/strings.fth
+++ b/fth/strings.fth
@@ -1,97 +1,97 @@
-\ @(#) strings.fth 98/01/26 1.2\r
-\ String support for PForth\r
-\\r
-\ Copyright Phil Burk 1994\r
-\r
-ANEW TASK-STRINGS.FTH\r
-\r
-: -TRAILING  ( c-addr u1 -- c-addr u2 , strip trailing blanks )\r
-       dup 0>\r
-       IF\r
-               BEGIN\r
-                       2dup 1- chars + c@ bl =\r
-                       over 0> and\r
-               WHILE\r
-                       1-\r
-               REPEAT\r
-       THEN\r
-;\r
-\r
-\ Structure of string table\r
-: $ARRAY  (  )\r
-    CREATE  ( #strings #chars_max --  )\r
-        dup ,\r
-        2+ * even-up allot\r
-    DOES>    ( index -- $addr )\r
-        dup @  ( get #chars )\r
-        rot * + cell+\r
-;\r
-\r
-\ Compare two strings\r
-: $= ( $1 $2 -- flag , true if equal )\r
-    -1 -rot\r
-    dup c@ 1+ 0\r
-    DO  dup c@ tolower\r
-        2 pick c@ tolower -\r
-        IF rot drop 0 -rot LEAVE\r
-        THEN\r
-               1+ swap 1+ swap\r
-    LOOP 2drop\r
-;\r
-\r
-: TEXT=  ( addr1 addr2 count -- flag )\r
-    >r -1 -rot\r
-       r> 0\r
-    ?DO  dup c@ tolower\r
-        2 pick c@ tolower -\r
-        IF rot drop 0 -rot LEAVE\r
-        THEN\r
-               1+ swap 1+ swap\r
-    LOOP 2drop\r
-;\r
-\r
-: TEXT=?  ( addr1 count addr2 -- flag , for JForth compatibility )\r
-       swap text=\r
-;\r
-\r
-: $MATCH?  ( $string1 $string2 -- flag , case INsensitive )\r
-       dup c@ 1+ text=\r
-;\r
-\r
-\r
-: INDEX ( $string char -- false | address_char true , search for char in string )\r
-    >r >r 0 r> r>\r
-    over c@ 1+ 1\r
-    DO  over i + c@ over =\r
-        IF  rot drop\r
-            over i + rot rot LEAVE\r
-        THEN\r
-    LOOP 2drop\r
-    ?dup 0= 0=\r
-;\r
-\r
-\r
-: $APPEND.CHAR  ( $string char -- ) \ ugly stack diagram\r
-    over count chars + c!\r
-    dup c@ 1+ swap c!\r
-;\r
-\r
-\ ----------------------------------------------\r
-: ($ROM)  ( index address -- $string )\r
-    ( -- index address )\r
-    swap 0\r
-    ?DO dup c@ 1+ + aligned\r
-    LOOP\r
-;\r
-\r
-: $ROM ( packed array of strings, unalterable )\r
-    CREATE ( <name> -- )\r
-    DOES> ( index -- $string )  ($rom)\r
-;\r
-\r
-: TEXTROM ( packed array of strings, unalterable )\r
-    CREATE ( <name> -- )\r
-    DOES> ( index -- address count )  ($rom) count\r
-;\r
-\r
-\ -----------------------------------------------\r
+\ @(#) strings.fth 98/01/26 1.2
+\ String support for PForth
+\
+\ Copyright Phil Burk 1994
+
+ANEW TASK-STRINGS.FTH
+
+: -TRAILING  ( c-addr u1 -- c-addr u2 , strip trailing blanks )
+    dup 0>
+    IF
+        BEGIN
+            2dup 1- chars + c@ bl =
+            over 0> and
+        WHILE
+            1-
+        REPEAT
+    THEN
+;
+
+\ Structure of string table
+: $ARRAY  (  )
+    CREATE  ( #strings #chars_max --  )
+        dup ,
+        2+ * even-up allot
+    DOES>    ( index -- $addr )
+        dup @  ( get #chars )
+        rot * + cell+
+;
+
+\ Compare two strings
+: $= ( $1 $2 -- flag , true if equal )
+    -1 -rot
+    dup c@ 1+ 0
+    DO  dup c@ tolower
+        2 pick c@ tolower -
+        IF rot drop 0 -rot LEAVE
+        THEN
+        1+ swap 1+ swap
+    LOOP 2drop
+;
+
+: TEXT=  ( addr1 addr2 count -- flag )
+    >r -1 -rot
+    r> 0
+    ?DO  dup c@ tolower
+        2 pick c@ tolower -
+        IF rot drop 0 -rot LEAVE
+        THEN
+        1+ swap 1+ swap
+    LOOP 2drop
+;
+
+: TEXT=?  ( addr1 count addr2 -- flag , for JForth compatibility )
+    swap text=
+;
+
+: $MATCH?  ( $string1 $string2 -- flag , case INsensitive )
+    dup c@ 1+ text=
+;
+
+
+: INDEX ( $string char -- false | address_char true , search for char in string )
+    >r >r 0 r> r>
+    over c@ 1+ 1
+    DO  over i + c@ over =
+        IF  rot drop
+            over i + rot rot LEAVE
+        THEN
+    LOOP 2drop
+    ?dup 0= 0=
+;
+
+
+: $APPEND.CHAR  ( $string char -- ) \ ugly stack diagram
+    over count chars + c!
+    dup c@ 1+ swap c!
+;
+
+\ ----------------------------------------------
+: ($ROM)  ( index address -- $string )
+    ( -- index address )
+    swap 0
+    ?DO dup c@ 1+ + aligned
+    LOOP
+;
+
+: $ROM ( packed array of strings, unalterable )
+    CREATE ( <name> -- )
+    DOES> ( index -- $string )  ($rom)
+;
+
+: TEXTROM ( packed array of strings, unalterable )
+    CREATE ( <name> -- )
+    DOES> ( index -- address count )  ($rom) count
+;
+
+\ -----------------------------------------------

diff --git a/fth/system.fth b/fth/system.fth
index 5cf36f8..b74c812 100644 (file)
--- a/fth/system.fth
+++ b/fth/system.fth
@@ -1,824 +1,824 @@
-: FIRST_COLON ;\r
-\r
-: LATEST context @ ;\r
-\r
-: FLAG_IMMEDIATE 64 ;\r
-\r
-: IMMEDIATE\r
-        latest dup c@ flag_immediate OR\r
-        swap c!\r
-;\r
-\r
-: (   41 word drop ; immediate\r
-( That was the definition for the comment word. )\r
-( Now we can add comments to what we are doing! )\r
-( Note that we are in decimal numeric input mode. )\r
-\r
-: \ ( <line> -- , comment out rest of line )\r
-        EOL word drop\r
-; immediate\r
-\r
-\ 1 echo !  \ Uncomment this line to echo Forth code while compiling.\r
-\r
-\ *********************************************************************\r
-\ This is another style of comment that is common in Forth.\r
-\ pFORTH - Portable Forth System\r
-\ Based on HMSL Forth\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\ *********************************************************************\r
-\r
-: COUNT  dup 1+ swap c@ ;\r
-\r
-\ Miscellaneous support words\r
-: ON ( addr -- , set true )\r
-        -1 swap !\r
-;\r
-: OFF ( addr -- , set false )\r
-        0 swap !\r
-;\r
-\r
-: CELL+ ( n -- n+cell )  cell + ;\r
-: CELL- ( n -- n+cell )  cell - ;\r
+: FIRST_COLON ;
+
+: LATEST context @ ;
+
+: FLAG_IMMEDIATE 64 ;
+
+: IMMEDIATE
+        latest dup c@ flag_immediate OR
+        swap c!
+;
+
+: (   41 word drop ; immediate
+( That was the definition for the comment word. )
+( Now we can add comments to what we are doing! )
+( Note that we are in decimal numeric input mode. )
+
+: \ ( <line> -- , comment out rest of line )
+        EOL word drop
+; immediate
+
+\ 1 echo !  \ Uncomment this line to echo Forth code while compiling.
+
+\ *********************************************************************
+\ This is another style of comment that is common in Forth.
+\ pFORTH - Portable Forth System
+\ Based on HMSL Forth
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+\ *********************************************************************
+
+: COUNT  dup 1+ swap c@ ;
+
+\ Miscellaneous support words
+: ON ( addr -- , set true )
+        -1 swap !
+;
+: OFF ( addr -- , set false )
+        0 swap !
+;
+
+: CELL+ ( n -- n+cell )  cell + ;
+: CELL- ( n -- n+cell )  cell - ;

 : CELL* ( n -- n*cell )  cells ;
 : CELL* ( n -- n*cell )  cells ;

-\r
-: CHAR+ ( n -- n+size_of_char ) 1+ ;\r
-: CHARS ( n -- n*size_of_char , don't do anything)  ; immediate\r
-\r
-\ useful stack manipulation words\r
-: -ROT ( a b c -- c a b )\r
-        rot rot\r
-;\r
-: 3DUP ( a b c -- a b c a b c )\r
-        2 pick 2 pick 2 pick\r
-;\r
-: 2DROP ( a b -- )\r
-        drop drop\r
-;\r
-: NIP ( a b -- b )\r
-        swap drop\r
-;\r
-: TUCK ( a b -- b a b )\r
-        swap over\r
-;\r
-\r
-: <= ( a b -- f , true if A <= b )\r
-        > 0=\r
-;\r
-: >= ( a b -- f , true if A >= b )\r
-        < 0=\r
-;\r
-\r
-: INVERT ( n -- 1'comp )\r
-    -1 xor\r
-;\r
-\r
-: NOT ( n -- !n , logical negation )\r
-        0=\r
-;\r
-\r
-: NEGATE ( n -- -n )\r
-        0 swap -\r
-;\r
-\r
-: DNEGATE ( d -- -d , negate by doing 0-d )\r
-        0 0 2swap d-\r
-;\r
-\r
-\r
-\ --------------------------------------------------------------------\r
-\r
-: ID.   ( nfa -- )\r
-    count 31 and type\r
-;\r
-\r
-: DECIMAL   10 base !  ;\r
-: OCTAL      8 base !  ;\r
-: HEX       16 base !  ;\r
-: BINARY     2 base !  ;\r
-\r
-: PAD ( -- addr )\r
-        here 128 +\r
-;\r
-\r
-: $MOVE ( $src $dst -- )\r
-        over c@ 1+ cmove\r
-;\r
-: BETWEEN ( n lo hi -- flag , true if between lo & hi )\r
-        >r over r> > >r\r
-        < r> or 0=\r
-;\r
-: [ ( -- , enter interpreter mode )\r
-        0 state !\r
-; immediate\r
-: ] ( -- enter compile mode )\r
-        1 state !\r
-;\r
-\r
-: EVEN-UP  ( n -- n | n+1 , make even )  dup 1 and +  ;\r
-: ALIGNED  ( addr -- a-addr )\r
-        [ cell 1- ] literal +\r
-        [ cell 1- invert ] literal and\r
-;\r
-: ALIGN ( -- , align DP )  dp @ aligned dp ! ;\r
-: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;\r
-\r
-: C,    ( c -- )  here c! 1 chars dp +! ;\r
-: W,    ( w -- )  dp @ even-up dup dp !    w!  2 chars dp +! ;\r
-: , ( n -- , lay into dictionary )  align here !  cell allot ;\r
-\r
-\ Dictionary conversions ------------------------------------------\r
-\r
-: N>NEXTLINK  ( nfa -- nextlink , traverses name field )\r
-        dup c@ 31 and 1+ + aligned\r
-;\r
-\r
-: NAMEBASE  ( -- base-of-names )\r
-        Headers-Base @\r
-;\r
-: CODEBASE  ( -- base-of-code dictionary )\r
-        Code-Base @\r
-;\r
-\r
-: NAMELIMIT  ( -- limit-of-names )\r
-        Headers-limit @\r
-;\r
-: CODELIMIT  ( -- limit-of-code, last address in dictionary )\r
-        Code-limit @\r
-;\r
-\r
-: NAMEBASE+   ( rnfa -- nfa , convert relocatable nfa to actual )\r
-        namebase +\r
-;\r
-\r
-: >CODE ( xt -- secondary_code_address, not valid for primitives )\r
-        codebase +\r
-;\r
-\r
-: CODE> ( secondary_code_address -- xt , not valid for primitives )\r
-        codebase -\r
-;\r
-\r
-: N>LINK  ( nfa -- lfa )\r
-        2 CELLS -\r
-;\r
-\r
-: >BODY   ( xt -- pfa )\r
-    >code body_offset +\r
-;\r
-\r
-: BODY>   ( pfa -- xt )\r
-    body_offset - code>\r
-;\r
-\r
-\ convert between addresses useable by @, and relocatable addresses.\r
-: USE->REL  ( useable_addr -- rel_addr )\r
-        codebase -\r
-;\r
-: REL->USE  ( rel_addr -- useable_addr )\r
-        codebase +\r
-;\r
-\r
-\ for JForth code\r
-\ : >REL  ( adr -- adr )  ; immediate\r
-\ : >ABS  ( adr -- adr )  ; immediate\r
-\r
-: X@ ( addr -- xt , fetch execution token from relocatable )   @ ;\r
-: X! ( addr -- xt , store execution token as relocatable )   ! ;\r
-\r
-\ Compiler support ------------------------------------------------\r
-: COMPILE, ( xt -- , compile call to xt )\r
-        ,\r
-;\r
-\r
-( Compiler support , based on FIG )\r
-: [COMPILE]  ( <name> -- , compile now even if immediate )\r
-    ' compile,\r
-;  IMMEDIATE\r
-\r
-: (COMPILE) ( xt -- , postpone compilation of token )\r
-        [compile] literal       ( compile a call to literal )\r
-        ( store xt of word to be compiled )\r
-        \r
-        [ ' compile, ] literal   \ compile call to compile,\r
-        compile,\r
-;\r
-        \r
-: COMPILE  ( <name> -- , save xt and compile later )\r
-    ' (compile)\r
-; IMMEDIATE\r
-\r
-\r
-: :NONAME ( -- xt , begin compilation of headerless secondary )\r
-        align\r
-        here code>   \ convert here to execution token\r
-        ]\r
-;\r
-\r
-\ Error codes defined in ANSI Exception word set.\r
-: ERR_ABORT         -1 ;   \ general abort\r
-: ERR_ABORTQ        -2 ;   \ for abort"\r
-: ERR_EXECUTING    -14 ;   \ compile time word while not compiling\r
-: ERR_PAIRS        -22 ;   \ mismatch in conditional\r
-: ERR_DEFER       -258 ;  \ not a deferred word\r
-\r
-: ABORT ( i*x -- )\r
-       ERR_ABORT throw\r
-;\r
-\r
-\ Conditionals in '83 form -----------------------------------------\r
-: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;\r
-: ?CONDITION   ( f -- )  conditional_key - err_pairs ?error ;\r
-: >MARK      ( -- addr )   here 0 ,  ;\r
-: >RESOLVE   ( addr -- )   here over - swap !  ;\r
-: <MARK      ( -- addr )   here  ;\r
-: <RESOLVE   ( addr -- )   here - ,  ;\r
-\r
-: ?COMP  ( -- , error if not compiling )\r
-        state @ 0= err_executing ?error\r
-;\r
-: ?PAIRS ( n m -- )\r
-        - err_pairs ?error\r
-;\r
-\ conditional primitives\r
-: IF     ( -- f orig )  ?comp compile 0branch  conditional_key >mark     ; immediate\r
-: THEN   ( f orig -- )  swap ?condition  >resolve   ; immediate\r
-: BEGIN  ( -- f dest )  ?comp conditional_key <mark   ; immediate\r
-: AGAIN  ( f dest -- )  compile branch  swap ?condition  <resolve  ; immediate\r
-: UNTIL  ( f dest -- )  compile 0branch swap ?condition  <resolve  ; immediate\r
-: AHEAD  ( -- f orig )  compile branch   conditional_key >mark     ; immediate\r
-\r
-\ conditionals built from primitives\r
-: ELSE   ( f orig1 -- f orig2 )\r
-       [compile] AHEAD  2swap [compile] THEN  ; immediate\r
-: WHILE  ( f dest -- f orig f dest )  [compile]  if   2swap ; immediate\r
-: REPEAT ( -- f orig f dest ) [compile] again  [compile] then  ; immediate\r
-\r
-: [']  ( <name> -- xt , define compile time tick )\r
-        ?comp ' [compile] literal\r
-; immediate\r
-\r
-\ for example:\r
-\ compile time:  compile create , (does>) then ;\r
-\ execution time:  create <name>, ',' data, then patch pi to point to @\r
-\    : con create , does> @ ;\r
-\    345 con pi\r
-\    pi\r
-\ \r
-: (DOES>)  ( xt -- , modify previous definition to execute code at xt )\r
-        latest name> >code \ get address of code for new word\r
-        cell + \ offset to second cell in create word\r
-        !      \ store execution token of DOES> code in new word\r
-;\r
-\r
-: DOES>   ( -- , define execution code for CREATE word )\r
-        0 [compile] literal \ dummy literal to hold xt\r
-        here cell-          \ address of zero in literal\r
-        compile (does>)     \ call (DOES>) from new creation word\r
-               >r                  \ move addrz to return stack so ; doesn't see stack garbage\r
-        [compile] ;         \ terminate part of code before does>\r
-               r>\r
-        :noname       ( addrz xt )\r
-        swap !              \ save execution token in literal\r
-; immediate\r
-\r
-: VARIABLE  ( <name> -- )\r
-    CREATE 0 , \ IMMEDIATE\r
-\       DOES> [compile] aliteral  \ %Q This could be optimised\r
-;\r
-\r
-: 2VARIABLE  ( <name> -c- ) ( -x- addr )\r
-        create 0 , 0 ,\r
-;\r
-\r
-: CONSTANT  ( n <name> -c- ) ( -x- n )\r
-        CREATE , ( n -- )\r
-        DOES> @ ( -- n )\r
-;\r
-\r
-\r
-\r
-0 1- constant -1\r
-0 2- constant -2\r
-\r
-: 2! ( x1 x2 addr -- , store x2 followed by x1 )\r
-        swap over ! cell+ !\r
-;\r
-: 2@ ( addr -- x1 x2 )\r
-        dup cell+ @ swap @\r
-;\r
-\r
-\r
-: ABS ( n -- |n| )\r
-        dup 0<\r
-        IF negate\r
-        THEN\r
-;\r
-: DABS ( d -- |d| )\r
-        dup 0<\r
-        IF dnegate\r
-        THEN\r
-;\r
-\r
-: S>D  ( s -- d , extend signed single precision to double )\r
-        dup 0<\r
-        IF -1\r
-        ELSE 0\r
-        THEN\r
-;\r
-\r
-: D>S ( d -- s ) drop ;\r
-\r
-: /MOD ( a b -- rem quo , unsigned version, FIXME )\r
-        >r s>d r> um/mod\r
-;\r
-\r
-: MOD ( a b -- rem )\r
-        /mod drop\r
-;\r
-\r
-: 2* ( n -- n*2 )\r
-        1 lshift\r
-;\r
-: 2/ ( n -- n/2 )\r
-        1 arshift\r
-;\r
-\r
-: D2*  ( d -- d*2 )\r
-        2* over 
-        cell 8 * 1- rshift or  swap\r
-        2* swap\r
-;\r
-\r
-\ define some useful constants ------------------------------\r
-1 0= constant FALSE\r
-0 0= constant TRUE\r
-32 constant BL\r
-\r
-\r
-\ Store and Fetch relocatable data addresses. ---------------\r
-: IF.USE->REL  ( use -- rel , preserve zero )\r
-        dup IF use->rel THEN\r
-;\r
-: IF.REL->USE  ( rel -- use , preserve zero )\r
-        dup IF rel->use THEN\r
-;\r
-\r
-: A!  ( dictionary_address addr -- )\r
-    >r if.use->rel r> !\r
-;\r
-: A@  ( addr -- dictionary_address )\r
-    @ if.rel->use\r
-;\r
-\r
-: A, ( dictionary_address -- )\r
-    if.use->rel ,\r
-;\r
-\r
-\ Stack data structure ----------------------------------------\r
-\ This is a general purpose stack utility used to implement necessary\r
-\ stacks for the compiler or the user.  Not real fast.\r
-\ These stacks grow up which is different then normal.\r
-\   cell 0 - stack pointer, offset from pfa of word\r
-\   cell 1 - limit for range checking\r
-\   cell 2 - first data location\r
-\r
-: :STACK   ( #cells -- )\r
-        CREATE  2 cells ,          ( offset of first data location )\r
-                dup ,              ( limit for range checking, not currently used )\r
-                cells cell+ allot  ( allot an extra cell for safety )\r
-;\r
-\r
-: >STACK  ( n stack -- , push onto stack, postincrement )\r
-        dup @ 2dup cell+ swap ! ( -- n stack offset )\r
-        + !\r
-;\r
-\r
-: STACK>  ( stack -- n , pop , predecrement )\r
-        dup @ cell- 2dup swap !\r
-        + @\r
-;\r
-\r
-: STACK@ ( stack -- n , copy )\r
-        dup @ cell- + @ \r
-;\r
-\r
-: STACK.PICK ( index stack -- n , grab Nth from top of stack )\r
-        dup @ cell- +\r
-        swap cells -   \ offset for index\r
-        @ \r
-;\r
-: STACKP ( stack -- ptr , to next empty location on stack )\r
-       dup @ +\r
-;\r
-\r
-: 0STACKP  ( stack -- , clear stack)\r
-    8 swap !\r
-;\r
-\r
-32 :stack ustack\r
-ustack 0stackp\r
-\r
-\ Define JForth like words.\r
-: >US ustack >stack ;\r
-: US> ustack stack> ;\r
-: US@ ustack stack@ ;\r
-: 0USP ustack 0stackp ;\r
-\r
-\r
-\ DO LOOP ------------------------------------------------\r
-\r
-3 constant do_flag\r
-4 constant leave_flag\r
-5 constant ?do_flag\r
-\r
-: DO    ( -- , loop-back do_flag jump-from ?do_flag )\r
-        ?comp\r
-        compile  (do)\r
-        here >us do_flag  >us  ( for backward branch )\r
-; immediate\r
-\r
-: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )\r
-        ?comp\r
-        ( leave address to set for forward branch )\r
-        compile  (?do)\r
-        here 0 ,\r
-        here >us do_flag  >us  ( for backward branch )\r
-        >us ( for forward branch ) ?do_flag >us\r
-; immediate\r
-\r
-: LEAVE  ( -- addr leave_flag )\r
-        compile (leave)\r
-        here 0 , >us\r
-        leave_flag >us\r
-; immediate\r
-\r
-: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )\r
-        BEGIN\r
-                us@ leave_flag =\r
-                us@ ?do_flag =\r
-                OR\r
-        WHILE\r
-                us> leave_flag =\r
-                IF\r
-                        us> here over - cell+ swap !\r
-                ELSE\r
-                        us> dup\r
-                        here swap -\r
-                        cell+ swap !\r
-                THEN\r
-        REPEAT\r
-;\r
-\r
-: LOOP-BACK  (  loop-addr do_flag -us- )\r
-        us> do_flag ?pairs\r
-        us> here -  here\r
-        !\r
-        cell allot\r
-;\r
-\r
-: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )\r
-   compile  (loop)\r
-   loop-forward loop-back\r
-; immediate\r
-\r
-\ : DOTEST 5 0 do 333 . loop 888 . ;\r
-\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;\r
-\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;\r
-\r
-: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )\r
-   compile  (+loop)\r
-   loop-forward loop-back\r
-; immediate\r
-        \r
-: UNLOOP ( loop-sys -r- )\r
-        r> \ save return pointer\r
-        rdrop rdrop\r
-        >r\r
-;\r
-\r
-: RECURSE ( ? -- ? , call the word currently being defined )\r
-        latest  name> compile,\r
-; immediate\r
-\r
-\r
-\r
-: SPACE  bl emit ;\r
-: SPACES  512 min 0 max 0 ?DO space LOOP ;\r
-: 0SP depth 0 ?do drop loop ;\r
-\r
-: >NEWLINE ( -- , CR if needed )\r
-        out @ 0>\r
-        IF cr\r
-        THEN\r
-;\r
-\r
-\r
-\ Support for DEFER --------------------\r
-: CHECK.DEFER  ( xt -- , error if not a deferred word by comparing to type )\r
-    >code @\r
-        ['] emit >code @\r
-        - err_defer ?error\r
-;\r
-\r
-: >is ( xt -- address_of_vector )\r
-        >code\r
-        cell +\r
-;\r
-\r
-: (IS)  ( xt_do xt_deferred -- )\r
-        >is !\r
-;\r
-\r
-: IS  ( xt <name> -- , act like normal IS )\r
-        '  \ xt\r
-        dup check.defer \r
-        state @\r
-        IF [compile] literal compile (is)\r
-        ELSE (is)\r
-        THEN\r
-; immediate\r
-\r
-: (WHAT'S)  ( xt -- xt_do )\r
-        >is @\r
-;\r
-: WHAT'S  ( <name> -- xt , what will deferred word call? )\r
-        '  \ xt\r
-        dup check.defer\r
-        state @\r
-        IF [compile] literal compile (what's)\r
-        ELSE (what's)\r
-        THEN\r
-; immediate\r
-\r
-: /STRING   ( addr len n -- addr' len' )\r
-   over min  rot over   +  -rot  -\r
-;\r
-: PLACE   ( addr len to -- , move string )\r
-   3dup  1+  swap cmove  c! drop\r
-;\r
-\r
-: PARSE-WORD   ( char -- addr len )\r
-   >r  source tuck >in @ /string  r@ skip over swap r> scan\r
-   >r  over -  rot r>  dup 0<> + - >in !\r
-;\r
-: PARSE   ( char -- addr len )\r
-   >r  source >in @  /string  over swap  r> scan\r
-   >r  over -  dup r> 0<>  -  >in +!\r
-;\r
-\r
-: LWORD  ( char -- addr )\r
-        parse-word here place here \ 00002 , use PARSE-WORD\r
-;\r
-\r
-: ASCII ( <char> -- char , state smart )\r
-        bl parse drop c@\r
-        state @\r
-        IF [compile] literal\r
-        THEN\r
-; immediate\r
-\r
-: CHAR ( <char> -- char , interpret mode )\r
-        bl parse drop c@\r
-;\r
-\r
-: [CHAR] ( <char> -- char , for compile mode )\r
-        char [compile] literal\r
-; immediate\r
-\r
-: $TYPE  ( $string -- )\r
-        count type\r
-;\r
-\r
-: 'word   ( -- addr )   here ;\r
-\r
-: EVEN    ( addr -- addr' )   dup 1 and +  ;\r
-\r
-: (C")   ( -- $addr , some Forths return addr AND count, OBSOLETE?)\r
-        r> dup count + aligned >r\r
-;\r
-: (S")   ( -- c-addr cnt )\r
-        r> count 2dup + aligned >r\r
-;\r
-\r
-: (.")  ( -- , type following string )\r
-        r> count 2dup + aligned >r type\r
-;\r
-\r
-: ",  ( adr len -- , place string into dictionary )\r
-         tuck 'word place 1+ allot align\r
-;\r
-: ,"   ( -- )\r
-   [char] " parse ",\r
-;\r
-\r
-: .(  ( <string> -- , type string delimited by parentheses )\r
-       [CHAR] ) PARSE TYPE\r
-; IMMEDIATE\r
-\r
-: ."   ( <string> -- , type string )\r
-        state @\r
-        IF      compile (.")  ,"\r
-        ELSE [char] " parse type\r
-        THEN\r
-; immediate\r
-\r
-\r
-: .'   ( <string> -- , type string delimited by single quote )\r
-        state @\r
-        IF    compile (.")  [char] ' parse ",\r
-        ELSE [char] ' parse type\r
-        THEN\r
-; immediate\r
-\r
-: C"    ( <string> -- addr , return string address, ANSI )\r
-        state @\r
-        IF compile (c")   ,"\r
-        ELSE [char] " parse pad place pad\r
-        THEN\r
-; immediate\r
-\r
-: S"    ( <string> -- , -- addr , return string address, ANSI )\r
-        state @\r
-        IF compile (s")   ,"\r
-        ELSE [char] " parse pad place pad count\r
-        THEN\r
-; immediate\r
-\r
-: "    ( <string> -- , -- addr , return string address )\r
-        [compile] C"\r
-; immediate\r
-: P"    ( <string> -- , -- addr , return string address )\r
-        [compile] C"\r
-; immediate\r
-\r
-: ""  ( <string> -- addr )\r
-        state @\r
-        IF \r
-                compile (C")\r
-                bl parse-word  ",\r
-        ELSE\r
-                bl parse-word pad place pad\r
-        THEN\r
-; immediate\r
-\r
-: SLITERAL ( addr cnt -- , compile string )\r
-       compile (S")\r
-       ",\r
-; IMMEDIATE\r
-\r
-: $APPEND ( addr count $1 -- , append text to $1 )\r
-    over >r\r
-        dup >r\r
-    count +  ( -- a2 c2 end1 )\r
-    swap cmove\r
-    r> dup c@  ( a1 c1 )\r
-    r> + ( -- a1 totalcount )\r
-    swap c!\r
-;\r
-\r
-\r
-\ ANSI word to replace [COMPILE] and COMPILE ----------------\r
-: POSTPONE  ( <name> -- )\r
-       bl word find\r
-       dup 0=\r
-       IF\r
-               ." Postpone could not find " count type cr abort\r
-       ELSE\r
-               0>\r
-               IF compile,  \ immediate\r
-               ELSE (compile)  \ normal\r
-               THEN\r
-       THEN\r
-; immediate\r
-\r
-\ -----------------------------------------------------------------\r
-\ Auto Initialization\r
-: AUTO.INIT  ( -- )\r
-\ Kernel finds AUTO.INIT and executes it after loading dictionary.\r
-\      ." Begin AUTO.INIT ------" cr\r
-;\r
-: AUTO.TERM  ( -- )\r
-\ Kernel finds AUTO.TERM and executes it on bye.\r
-\      ." End AUTO.TERM ------" cr\r
-;\r
-\r
-\ -------------- INCLUDE ------------------------------------------\r
-variable TRACE-INCLUDE\r
-\r
-: INCLUDE.MARK.START  ( $filename -- , mark start of include for FILE?)\r
-       " ::::"  pad $MOVE\r
-       count pad $APPEND\r
-       pad ['] noop (:)\r
-;\r
-\r
-: INCLUDE.MARK.END  ( -- , mark end of include )\r
-       " ;;;;" ['] noop (:)\r
-;\r
-\r
-: $INCLUDE ( $filename -- )\r
-\ Print messages.\r
-        trace-include @\r
-        IF\r
-                >newline ." Include " dup count type cr\r
-        THEN\r
-        here >r\r
-        dup\r
-        count r/o open-file \r
-        IF  ( -- $filename bad-fid )\r
-                drop ." Could not find file " $type cr abort\r
-        ELSE ( -- $filename good-fid )\r
-                swap include.mark.start\r
-                depth >r\r
-                include-file    \ will also close the file\r
-                depth 1+ r> -\r
-                IF\r
-                        ." Warning: stack depth changed during include!" cr\r
-                        .s cr\r
-                        0sp\r
-                THEN\r
-                include.mark.end\r
-        THEN\r
-        trace-include @\r
-        IF\r
-                ."     include added " here r@ - . ." bytes,"\r
-                codelimit here - . ." left." cr\r
-        THEN\r
-        rdrop\r
-;\r
-\r
-create INCLUDE-SAVE-NAME 128 allot\r
-: INCLUDE ( <fname> -- )\r
-        BL lword\r
-        dup include-save-name $move  \ save for RI\r
-        $include\r
-;\r
-\r
-: RI ( -- , ReInclude previous file as a convenience )\r
-        include-save-name $include\r
-;\r
-\r
-: INCLUDE? ( <word> <file> -- , load file if word not defined )\r
-        bl word find\r
-        IF drop bl word drop  ( eat word from source )\r
-        ELSE drop include\r
-        THEN\r
-;\r
-\r
-\ desired sizes for dictionary loaded after SAVE-FORTH\r
-variable HEADERS-SIZE  \r
-variable CODE-SIZE\r
-\r
-: AUTO.INIT\r
-       auto.init\r
-       codelimit codebase - code-size !\r
-       namelimit namebase - headers-size !\r
-;\r
-auto.init\r
-\r
-: SAVE-FORTH ( $name -- )\r
-    0                                    \ Entry point\r
-    headers-ptr @ namebase - 65536 +     \ NameSize\r
-    headers-size @ MAX\r
-    here codebase - 131072 +              \ CodeSize\r
-    code-size @ MAX\r
-    (save-forth)\r
-    IF\r
-               ." SAVE-FORTH failed!" cr abort\r
-    THEN\r
-;\r
-\r
-: TURNKEY ( $name entry-token-- )\r
-    0     \ NameSize = 0, names not saved in turnkey dictionary\r
-    here codebase - 131072 +             \ CodeSize, remember that base is HEX\r
-    (save-forth)\r
-    IF\r
-               ." TURNKEY failed!" cr abort\r
-    THEN\r
-;\r
-\r
-\ Now that we can load from files, load remainder of dictionary.\r
-\r
-trace-include on\r
-\ Turn this OFF if you do not want to see the contents of the stack after each entry.\r
-trace-stack off\r
-\r
-include loadp4th.fth\r
-\r
-decimal\r
-\r
-: ;;;; ;  \ Mark end of this file so FILE? can find things in here.\r
-FREEZE    \ prevent forgetting below this point\r
-\r
-.( Dictionary compiled, save in "pforth.dic".) cr\r
-c" pforth.dic" save-forth\r
+
+: CHAR+ ( n -- n+size_of_char ) 1+ ;
+: CHARS ( n -- n*size_of_char , don't do anything)  ; immediate
+
+\ useful stack manipulation words
+: -ROT ( a b c -- c a b )
+        rot rot
+;
+: 3DUP ( a b c -- a b c a b c )
+        2 pick 2 pick 2 pick
+;
+: 2DROP ( a b -- )
+        drop drop
+;
+: NIP ( a b -- b )
+        swap drop
+;
+: TUCK ( a b -- b a b )
+        swap over
+;
+
+: <= ( a b -- f , true if A <= b )
+        > 0=
+;
+: >= ( a b -- f , true if A >= b )
+        < 0=
+;
+
+: INVERT ( n -- 1'comp )
+    -1 xor
+;
+
+: NOT ( n -- !n , logical negation )
+        0=
+;
+
+: NEGATE ( n -- -n )
+        0 swap -
+;
+
+: DNEGATE ( d -- -d , negate by doing 0-d )
+        0 0 2swap d-
+;
+
+
+\ --------------------------------------------------------------------
+
+: ID.   ( nfa -- )
+    count 31 and type
+;
+
+: DECIMAL   10 base !  ;
+: OCTAL      8 base !  ;
+: HEX       16 base !  ;
+: BINARY     2 base !  ;
+
+: PAD ( -- addr )
+        here 128 +
+;
+
+: $MOVE ( $src $dst -- )
+        over c@ 1+ cmove
+;
+: BETWEEN ( n lo hi -- flag , true if between lo & hi )
+        >r over r> > >r
+        < r> or 0=
+;
+: [ ( -- , enter interpreter mode )
+        0 state !
+; immediate
+: ] ( -- enter compile mode )
+        1 state !
+;
+
+: EVEN-UP  ( n -- n | n+1 , make even )  dup 1 and +  ;
+: ALIGNED  ( addr -- a-addr )
+        [ cell 1- ] literal +
+        [ cell 1- invert ] literal and
+;
+: ALIGN ( -- , align DP )  dp @ aligned dp ! ;
+: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
+
+: C,    ( c -- )  here c! 1 chars dp +! ;
+: W,    ( w -- )  dp @ even-up dup dp !    w!  2 chars dp +! ;
+: , ( n -- , lay into dictionary )  align here !  cell allot ;
+
+\ Dictionary conversions ------------------------------------------
+
+: N>NEXTLINK  ( nfa -- nextlink , traverses name field )
+        dup c@ 31 and 1+ + aligned
+;
+
+: NAMEBASE  ( -- base-of-names )
+        Headers-Base @
+;
+: CODEBASE  ( -- base-of-code dictionary )
+        Code-Base @
+;
+
+: NAMELIMIT  ( -- limit-of-names )
+        Headers-limit @
+;
+: CODELIMIT  ( -- limit-of-code, last address in dictionary )
+        Code-limit @
+;
+
+: NAMEBASE+   ( rnfa -- nfa , convert relocatable nfa to actual )
+        namebase +
+;
+
+: >CODE ( xt -- secondary_code_address, not valid for primitives )
+        codebase +
+;
+
+: CODE> ( secondary_code_address -- xt , not valid for primitives )
+        codebase -
+;
+
+: N>LINK  ( nfa -- lfa )
+        2 CELLS -
+;
+
+: >BODY   ( xt -- pfa )
+    >code body_offset +
+;
+
+: BODY>   ( pfa -- xt )
+    body_offset - code>
+;
+
+\ convert between addresses useable by @, and relocatable addresses.
+: USE->REL  ( useable_addr -- rel_addr )
+        codebase -
+;
+: REL->USE  ( rel_addr -- useable_addr )
+        codebase +
+;
+
+\ for JForth code
+\ : >REL  ( adr -- adr )  ; immediate
+\ : >ABS  ( adr -- adr )  ; immediate
+
+: X@ ( addr -- xt , fetch execution token from relocatable )   @ ;
+: X! ( addr -- xt , store execution token as relocatable )   ! ;
+
+\ Compiler support ------------------------------------------------
+: COMPILE, ( xt -- , compile call to xt )
+        ,
+;
+
+( Compiler support , based on FIG )
+: [COMPILE]  ( <name> -- , compile now even if immediate )
+    ' compile,
+;  IMMEDIATE
+
+: (COMPILE) ( xt -- , postpone compilation of token )
+        [compile] literal       ( compile a call to literal )
+        ( store xt of word to be compiled )
+
+        [ ' compile, ] literal   \ compile call to compile,
+        compile,
+;
+
+: COMPILE  ( <name> -- , save xt and compile later )
+    ' (compile)
+; IMMEDIATE
+
+
+: :NONAME ( -- xt , begin compilation of headerless secondary )
+        align
+        here code>   \ convert here to execution token
+        ]
+;
+
+\ Error codes defined in ANSI Exception word set.
+: ERR_ABORT         -1 ;   \ general abort
+: ERR_ABORTQ        -2 ;   \ for abort"
+: ERR_EXECUTING    -14 ;   \ compile time word while not compiling
+: ERR_PAIRS        -22 ;   \ mismatch in conditional
+: ERR_DEFER       -258 ;  \ not a deferred word
+
+: ABORT ( i*x -- )
+    ERR_ABORT throw
+;
+
+\ Conditionals in '83 form -----------------------------------------
+: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
+: ?CONDITION   ( f -- )  conditional_key - err_pairs ?error ;
+: >MARK      ( -- addr )   here 0 ,  ;
+: >RESOLVE   ( addr -- )   here over - swap !  ;
+: <MARK      ( -- addr )   here  ;
+: <RESOLVE   ( addr -- )   here - ,  ;
+
+: ?COMP  ( -- , error if not compiling )
+        state @ 0= err_executing ?error
+;
+: ?PAIRS ( n m -- )
+        - err_pairs ?error
+;
+\ conditional primitives
+: IF     ( -- f orig )  ?comp compile 0branch  conditional_key >mark     ; immediate
+: THEN   ( f orig -- )  swap ?condition  >resolve   ; immediate
+: BEGIN  ( -- f dest )  ?comp conditional_key <mark   ; immediate
+: AGAIN  ( f dest -- )  compile branch  swap ?condition  <resolve  ; immediate
+: UNTIL  ( f dest -- )  compile 0branch swap ?condition  <resolve  ; immediate
+: AHEAD  ( -- f orig )  compile branch   conditional_key >mark     ; immediate
+
+\ conditionals built from primitives
+: ELSE   ( f orig1 -- f orig2 )
+    [compile] AHEAD  2swap [compile] THEN  ; immediate
+: WHILE  ( f dest -- f orig f dest )  [compile]  if   2swap ; immediate
+: REPEAT ( -- f orig f dest ) [compile] again  [compile] then  ; immediate
+
+: [']  ( <name> -- xt , define compile time tick )
+        ?comp ' [compile] literal
+; immediate
+
+\ for example:
+\ compile time:  compile create , (does>) then ;
+\ execution time:  create <name>, ',' data, then patch pi to point to @
+\    : con create , does> @ ;
+\    345 con pi
+\    pi
+\
+: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
+        latest name> >code \ get address of code for new word
+        cell + \ offset to second cell in create word
+        !      \ store execution token of DOES> code in new word
+;
+
+: DOES>   ( -- , define execution code for CREATE word )
+        0 [compile] literal \ dummy literal to hold xt
+        here cell-          \ address of zero in literal
+        compile (does>)     \ call (DOES>) from new creation word
+        >r                  \ move addrz to return stack so ; doesn't see stack garbage
+        [compile] ;         \ terminate part of code before does>
+        r>
+        :noname       ( addrz xt )
+        swap !              \ save execution token in literal
+; immediate
+
+: VARIABLE  ( <name> -- )
+    CREATE 0 , \ IMMEDIATE
+\       DOES> [compile] aliteral  \ %Q This could be optimised
+;
+
+: 2VARIABLE  ( <name> -c- ) ( -x- addr )
+        create 0 , 0 ,
+;
+
+: CONSTANT  ( n <name> -c- ) ( -x- n )
+        CREATE , ( n -- )
+        DOES> @ ( -- n )
+;
+
+
+
+0 1- constant -1
+0 2- constant -2
+
+: 2! ( x1 x2 addr -- , store x2 followed by x1 )
+        swap over ! cell+ !
+;
+: 2@ ( addr -- x1 x2 )
+        dup cell+ @ swap @
+;
+
+
+: ABS ( n -- |n| )
+        dup 0<
+        IF negate
+        THEN
+;
+: DABS ( d -- |d| )
+        dup 0<
+        IF dnegate
+        THEN
+;
+
+: S>D  ( s -- d , extend signed single precision to double )
+        dup 0<
+        IF -1
+        ELSE 0
+        THEN
+;
+
+: D>S ( d -- s ) drop ;
+
+: /MOD ( a b -- rem quo , unsigned version, FIXME )
+        >r s>d r> um/mod
+;
+
+: MOD ( a b -- rem )
+        /mod drop
+;
+
+: 2* ( n -- n*2 )
+        1 lshift
+;
+: 2/ ( n -- n/2 )
+        1 arshift
+;
+
+: D2*  ( d -- d*2 )
+        2* over
+        cell 8 * 1- rshift or  swap
+        2* swap
+;
+
+\ define some useful constants ------------------------------
+1 0= constant FALSE
+0 0= constant TRUE
+32 constant BL
+
+
+\ Store and Fetch relocatable data addresses. ---------------
+: IF.USE->REL  ( use -- rel , preserve zero )
+        dup IF use->rel THEN
+;
+: IF.REL->USE  ( rel -- use , preserve zero )
+        dup IF rel->use THEN
+;
+
+: A!  ( dictionary_address addr -- )
+    >r if.use->rel r> !
+;
+: A@  ( addr -- dictionary_address )
+    @ if.rel->use
+;
+
+: A, ( dictionary_address -- )
+    if.use->rel ,
+;
+
+\ Stack data structure ----------------------------------------
+\ This is a general purpose stack utility used to implement necessary
+\ stacks for the compiler or the user.  Not real fast.
+\ These stacks grow up which is different then normal.
+\   cell 0 - stack pointer, offset from pfa of word
+\   cell 1 - limit for range checking
+\   cell 2 - first data location
+
+: :STACK   ( #cells -- )
+        CREATE  2 cells ,          ( offset of first data location )
+                dup ,              ( limit for range checking, not currently used )
+                cells cell+ allot  ( allot an extra cell for safety )
+;
+
+: >STACK  ( n stack -- , push onto stack, postincrement )
+        dup @ 2dup cell+ swap ! ( -- n stack offset )
+        + !
+;
+
+: STACK>  ( stack -- n , pop , predecrement )
+        dup @ cell- 2dup swap !
+        + @
+;
+
+: STACK@ ( stack -- n , copy )
+        dup @ cell- + @
+;
+
+: STACK.PICK ( index stack -- n , grab Nth from top of stack )
+        dup @ cell- +
+        swap cells -   \ offset for index
+        @
+;
+: STACKP ( stack -- ptr , to next empty location on stack )
+    dup @ +
+;
+
+: 0STACKP  ( stack -- , clear stack)
+    8 swap !
+;
+
+32 :stack ustack
+ustack 0stackp
+
+\ Define JForth like words.
+: >US ustack >stack ;
+: US> ustack stack> ;
+: US@ ustack stack@ ;
+: 0USP ustack 0stackp ;
+
+
+\ DO LOOP ------------------------------------------------
+
+3 constant do_flag
+4 constant leave_flag
+5 constant ?do_flag
+
+: DO    ( -- , loop-back do_flag jump-from ?do_flag )
+        ?comp
+        compile  (do)
+        here >us do_flag  >us  ( for backward branch )
+; immediate
+
+: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
+        ?comp
+        ( leave address to set for forward branch )
+        compile  (?do)
+        here 0 ,
+        here >us do_flag  >us  ( for backward branch )
+        >us ( for forward branch ) ?do_flag >us
+; immediate
+
+: LEAVE  ( -- addr leave_flag )
+        compile (leave)
+        here 0 , >us
+        leave_flag >us
+; immediate
+
+: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
+        BEGIN
+                us@ leave_flag =
+                us@ ?do_flag =
+                OR
+        WHILE
+                us> leave_flag =
+                IF
+                        us> here over - cell+ swap !
+                ELSE
+                        us> dup
+                        here swap -
+                        cell+ swap !
+                THEN
+        REPEAT
+;
+
+: LOOP-BACK  (  loop-addr do_flag -us- )
+        us> do_flag ?pairs
+        us> here -  here
+        !
+        cell allot
+;
+
+: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
+   compile  (loop)
+   loop-forward loop-back
+; immediate
+
+\ : DOTEST 5 0 do 333 . loop 888 . ;
+\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
+\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;
+
+: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
+   compile  (+loop)
+   loop-forward loop-back
+; immediate
+
+: UNLOOP ( loop-sys -r- )
+        r> \ save return pointer
+        rdrop rdrop
+        >r
+;
+
+: RECURSE ( ? -- ? , call the word currently being defined )
+        latest  name> compile,
+; immediate
+
+
+
+: SPACE  bl emit ;
+: SPACES  512 min 0 max 0 ?DO space LOOP ;
+: 0SP depth 0 ?do drop loop ;
+
+: >NEWLINE ( -- , CR if needed )
+        out @ 0>
+        IF cr
+        THEN
+;
+
+
+\ Support for DEFER --------------------
+: CHECK.DEFER  ( xt -- , error if not a deferred word by comparing to type )
+    >code @
+        ['] emit >code @
+        - err_defer ?error
+;
+
+: >is ( xt -- address_of_vector )
+        >code
+        cell +
+;
+
+: (IS)  ( xt_do xt_deferred -- )
+        >is !
+;
+
+: IS  ( xt <name> -- , act like normal IS )
+        '  \ xt
+        dup check.defer
+        state @
+        IF [compile] literal compile (is)
+        ELSE (is)
+        THEN
+; immediate
+
+: (WHAT'S)  ( xt -- xt_do )
+        >is @
+;
+: WHAT'S  ( <name> -- xt , what will deferred word call? )
+        '  \ xt
+        dup check.defer
+        state @
+        IF [compile] literal compile (what's)
+        ELSE (what's)
+        THEN
+; immediate
+
+: /STRING   ( addr len n -- addr' len' )
+   over min  rot over   +  -rot  -
+;
+: PLACE   ( addr len to -- , move string )
+   3dup  1+  swap cmove  c! drop
+;
+
+: PARSE-WORD   ( char -- addr len )
+   >r  source tuck >in @ /string  r@ skip over swap r> scan
+   >r  over -  rot r>  dup 0<> + - >in !
+;
+: PARSE   ( char -- addr len )
+   >r  source >in @  /string  over swap  r> scan
+   >r  over -  dup r> 0<>  -  >in +!
+;
+
+: LWORD  ( char -- addr )
+        parse-word here place here \ 00002 , use PARSE-WORD
+;
+
+: ASCII ( <char> -- char , state smart )
+        bl parse drop c@
+        state @
+        IF [compile] literal
+        THEN
+; immediate
+
+: CHAR ( <char> -- char , interpret mode )
+        bl parse drop c@
+;
+
+: [CHAR] ( <char> -- char , for compile mode )
+        char [compile] literal
+; immediate
+
+: $TYPE  ( $string -- )
+        count type
+;
+
+: 'word   ( -- addr )   here ;
+
+: EVEN    ( addr -- addr' )   dup 1 and +  ;
+
+: (C")   ( -- $addr , some Forths return addr AND count, OBSOLETE?)
+        r> dup count + aligned >r
+;
+: (S")   ( -- c-addr cnt )
+        r> count 2dup + aligned >r
+;
+
+: (.")  ( -- , type following string )
+        r> count 2dup + aligned >r type
+;
+
+: ",  ( adr len -- , place string into dictionary )
+         tuck 'word place 1+ allot align
+;
+: ,"   ( -- )
+   [char] " parse ",
+;
+
+: .(  ( <string> -- , type string delimited by parentheses )
+    [CHAR] ) PARSE TYPE
+; IMMEDIATE
+
+: ."   ( <string> -- , type string )
+        state @
+        IF      compile (.")  ,"
+        ELSE [char] " parse type
+        THEN
+; immediate
+
+
+: .'   ( <string> -- , type string delimited by single quote )
+        state @
+        IF    compile (.")  [char] ' parse ",
+        ELSE [char] ' parse type
+        THEN
+; immediate
+
+: C"    ( <string> -- addr , return string address, ANSI )
+        state @
+        IF compile (c")   ,"
+        ELSE [char] " parse pad place pad
+        THEN
+; immediate
+
+: S"    ( <string> -- , -- addr , return string address, ANSI )
+        state @
+        IF compile (s")   ,"
+        ELSE [char] " parse pad place pad count
+        THEN
+; immediate
+
+: "    ( <string> -- , -- addr , return string address )
+        [compile] C"
+; immediate
+: P"    ( <string> -- , -- addr , return string address )
+        [compile] C"
+; immediate
+
+: ""  ( <string> -- addr )
+        state @
+        IF
+                compile (C")
+                bl parse-word  ",
+        ELSE
+                bl parse-word pad place pad
+        THEN
+; immediate
+
+: SLITERAL ( addr cnt -- , compile string )
+    compile (S")
+    ",
+; IMMEDIATE
+
+: $APPEND ( addr count $1 -- , append text to $1 )
+    over >r
+        dup >r
+    count +  ( -- a2 c2 end1 )
+    swap cmove
+    r> dup c@  ( a1 c1 )
+    r> + ( -- a1 totalcount )
+    swap c!
+;
+
+
+\ ANSI word to replace [COMPILE] and COMPILE ----------------
+: POSTPONE  ( <name> -- )
+    bl word find
+    dup 0=
+    IF
+        ." Postpone could not find " count type cr abort
+    ELSE
+        0>
+        IF compile,  \ immediate
+        ELSE (compile)  \ normal
+        THEN
+    THEN
+; immediate
+
+\ -----------------------------------------------------------------
+\ Auto Initialization
+: AUTO.INIT  ( -- )
+\ Kernel finds AUTO.INIT and executes it after loading dictionary.
+\   ." Begin AUTO.INIT ------" cr
+;
+: AUTO.TERM  ( -- )
+\ Kernel finds AUTO.TERM and executes it on bye.
+\   ." End AUTO.TERM ------" cr
+;
+
+\ -------------- INCLUDE ------------------------------------------
+variable TRACE-INCLUDE
+
+: INCLUDE.MARK.START  ( $filename -- , mark start of include for FILE?)
+    " ::::"  pad $MOVE
+    count pad $APPEND
+    pad ['] noop (:)
+;
+
+: INCLUDE.MARK.END  ( -- , mark end of include )
+    " ;;;;" ['] noop (:)
+;
+
+: $INCLUDE ( $filename -- )
+\ Print messages.
+        trace-include @
+        IF
+                >newline ." Include " dup count type cr
+        THEN
+        here >r
+        dup
+        count r/o open-file
+        IF  ( -- $filename bad-fid )
+                drop ." Could not find file " $type cr abort
+        ELSE ( -- $filename good-fid )
+                swap include.mark.start
+                depth >r
+                include-file    \ will also close the file
+                depth 1+ r> -
+                IF
+                        ." Warning: stack depth changed during include!" cr
+                        .s cr
+                        0sp
+                THEN
+                include.mark.end
+        THEN
+        trace-include @
+        IF
+                ."     include added " here r@ - . ." bytes,"
+                codelimit here - . ." left." cr
+        THEN
+        rdrop
+;
+
+create INCLUDE-SAVE-NAME 128 allot
+: INCLUDE ( <fname> -- )
+        BL lword
+        dup include-save-name $move  \ save for RI
+        $include
+;
+
+: RI ( -- , ReInclude previous file as a convenience )
+        include-save-name $include
+;
+
+: INCLUDE? ( <word> <file> -- , load file if word not defined )
+        bl word find
+        IF drop bl word drop  ( eat word from source )
+        ELSE drop include
+        THEN
+;
+
+\ desired sizes for dictionary loaded after SAVE-FORTH
+variable HEADERS-SIZE
+variable CODE-SIZE
+
+: AUTO.INIT
+    auto.init
+    codelimit codebase - code-size !
+    namelimit namebase - headers-size !
+;
+auto.init
+
+: SAVE-FORTH ( $name -- )
+    0                                    \ Entry point
+    headers-ptr @ namebase - 65536 +     \ NameSize
+    headers-size @ MAX
+    here codebase - 131072 +              \ CodeSize
+    code-size @ MAX
+    (save-forth)
+    IF
+        ." SAVE-FORTH failed!" cr abort
+    THEN
+;
+
+: TURNKEY ( $name entry-token-- )
+    0     \ NameSize = 0, names not saved in turnkey dictionary
+    here codebase - 131072 +             \ CodeSize, remember that base is HEX
+    (save-forth)
+    IF
+        ." TURNKEY failed!" cr abort
+    THEN
+;
+
+\ Now that we can load from files, load remainder of dictionary.
+
+trace-include on
+\ Turn this OFF if you do not want to see the contents of the stack after each entry.
+trace-stack off
+
+include loadp4th.fth
+
+decimal
+
+: ;;;; ;  \ Mark end of this file so FILE? can find things in here.
+FREEZE    \ prevent forgetting below this point
+
+.( Dictionary compiled, save in "pforth.dic".) cr
+c" pforth.dic" save-forth

diff --git a/fth/t_alloc.fth b/fth/t_alloc.fth
index 63bf0f1..92814e4 100644 (file)
--- a/fth/t_alloc.fth
+++ b/fth/t_alloc.fth
@@ -1,116 +1,116 @@
-\ @(#) t_alloc.fth 97/01/28 1.4\r
-\ Test PForth ALLOCATE\r
-\\r
-\ Copyright 1994 3DO, Phil Burk\r
-\r
-anew task-t_alloc.fth\r
-decimal\r
-\r
-64 constant NUM_TAF_SLOTS\r
-\r
-variable TAF-MAX-ALLOC\r
-variable TAF-MAX-SLOT\r
-\r
-\ hold addresses and sizes\r
-NUM_TAF_SLOTS array TAF-ADDRESSES\r
-NUM_TAF_SLOTS array TAF-SIZES\r
-\r
-: TAF.MAX.ALLOC? { | numb addr ior maxb -- max }\r
-        0 -> maxb\r
-\ determine maximum amount we can allocate\r
-        1024 40 * -> numb\r
-        BEGIN\r
-                numb 0>\r
-        WHILE\r
-                numb allocate -> ior -> addr\r
-                ior 0=\r
-                IF  \ success\r
-                        addr free abort" Free failed!"\r
-                        numb -> maxb\r
-                        0 -> numb\r
-                ELSE\r
-                        numb 1024 - -> numb\r
-                THEN\r
-        REPEAT\r
-        maxb\r
-;\r
-\r
-: TAF.INIT  ( -- )\r
-        NUM_TAF_SLOTS 0\r
-        DO\r
-                0 i taf-addresses !\r
-        LOOP\r
-\\r
-        taf.max.alloc? ." Total Avail = " dup . cr\r
-        dup taf-max-alloc !\r
-        NUM_TAF_SLOTS / taf-max-slot !\r
-;\r
-\r
-: TAF.ALLOC.SLOT { slotnum | addr size -- }\r
-\ allocate some RAM\r
-        taf-max-slot @ 8 -\r
-        choose 8 + \r
-        dup allocate abort" Allocation failed!"\r
-        -> addr\r
-        -> size\r
-        addr slotnum taf-addresses !\r
-        size slotnum taf-sizes !\r
-\\r
-\ paint RAM with slot number\r
-        addr size slotnum fill\r
-;\r
-\r
-: TAF.FREE.SLOT { slotnum | addr size -- }\r
-        slotnum taf-addresses @  -> addr\r
-\ something allocated so check it and free it.\r
-        slotnum taf-sizes @  0\r
-        DO\r
-                addr i + c@  slotnum -\r
-                IF\r
-                        ." Error at " addr i + .\r
-                        ." , slot# " slotnum . cr\r
-                        abort\r
-                THEN\r
-        LOOP\r
-        addr free abort" Free failed!"\r
-        0 slotnum taf-addresses !\r
-;\r
-\r
-: TAF.DO.SLOT { slotnum  -- }\r
-        slotnum taf-addresses @ 0=\r
-        IF\r
-                slotnum taf.alloc.slot\r
-        ELSE\r
-                slotnum taf.free.slot\r
-        THEN\r
-;\r
-\r
-: TAF.TERM\r
-        NUM_TAF_SLOTS 0\r
-        DO\r
-                i taf-addresses @\r
-                IF\r
-                        i taf.free.slot\r
-                THEN\r
-        LOOP\r
-\\r
-        taf.max.alloc? dup ." Final    MAX = " . cr\r
-        ." Original MAX = " taf-max-alloc @ dup . cr\r
-        = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr\r
-        \r
-;\r
-\r
-: TAF.TEST ( NumTests -- )\r
-        1 max\r
-        dup . ." tests" cr \ flushemit\r
-        taf.init\r
-        ." Please wait for test to complete..." cr\r
-        0\r
-        DO  NUM_TAF_SLOTS choose taf.do.slot\r
-        LOOP\r
-        taf.term\r
-;\r
-\r
-.( Testing ALLOCATE and FREE) cr\r
-10000 taf.test\r
-\r
+\ @(#) t_alloc.fth 97/01/28 1.4
+\ Test PForth ALLOCATE
+\
+\ Copyright 1994 3DO, Phil Burk
+
+anew task-t_alloc.fth
+decimal
+
+64 constant NUM_TAF_SLOTS
+
+variable TAF-MAX-ALLOC
+variable TAF-MAX-SLOT
+
+\ hold addresses and sizes
+NUM_TAF_SLOTS array TAF-ADDRESSES
+NUM_TAF_SLOTS array TAF-SIZES
+
+: TAF.MAX.ALLOC? { | numb addr ior maxb -- max }
+        0 -> maxb
+\ determine maximum amount we can allocate
+        1024 40 * -> numb
+        BEGIN
+                numb 0>
+        WHILE
+                numb allocate -> ior -> addr
+                ior 0=
+                IF  \ success
+                        addr free abort" Free failed!"
+                        numb -> maxb
+                        0 -> numb
+                ELSE
+                        numb 1024 - -> numb
+                THEN
+        REPEAT
+        maxb
+;
+
+: TAF.INIT  ( -- )
+        NUM_TAF_SLOTS 0
+        DO
+                0 i taf-addresses !
+        LOOP
+\
+        taf.max.alloc? ." Total Avail = " dup . cr
+        dup taf-max-alloc !
+        NUM_TAF_SLOTS / taf-max-slot !
+;
+
+: TAF.ALLOC.SLOT { slotnum | addr size -- }
+\ allocate some RAM
+        taf-max-slot @ 8 -
+        choose 8 +
+        dup allocate abort" Allocation failed!"
+        -> addr
+        -> size
+        addr slotnum taf-addresses !
+        size slotnum taf-sizes !
+\
+\ paint RAM with slot number
+        addr size slotnum fill
+;
+
+: TAF.FREE.SLOT { slotnum | addr size -- }
+        slotnum taf-addresses @  -> addr
+\ something allocated so check it and free it.
+        slotnum taf-sizes @  0
+        DO
+                addr i + c@  slotnum -
+                IF
+                        ." Error at " addr i + .
+                        ." , slot# " slotnum . cr
+                        abort
+                THEN
+        LOOP
+        addr free abort" Free failed!"
+        0 slotnum taf-addresses !
+;
+
+: TAF.DO.SLOT { slotnum  -- }
+        slotnum taf-addresses @ 0=
+        IF
+                slotnum taf.alloc.slot
+        ELSE
+                slotnum taf.free.slot
+        THEN
+;
+
+: TAF.TERM
+        NUM_TAF_SLOTS 0
+        DO
+                i taf-addresses @
+                IF
+                        i taf.free.slot
+                THEN
+        LOOP
+\
+        taf.max.alloc? dup ." Final    MAX = " . cr
+        ." Original MAX = " taf-max-alloc @ dup . cr
+        = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr
+
+;
+
+: TAF.TEST ( NumTests -- )
+        1 max
+        dup . ." tests" cr \ flushemit
+        taf.init
+        ." Please wait for test to complete..." cr
+        0
+        DO  NUM_TAF_SLOTS choose taf.do.slot
+        LOOP
+        taf.term
+;
+
+.( Testing ALLOCATE and FREE) cr
+10000 taf.test
+

diff --git a/fth/t_case.fth b/fth/t_case.fth
index e1997fb..664ea63 100644 (file)
--- a/fth/t_case.fth
+++ b/fth/t_case.fth
@@ -1,16 +1,16 @@
-\ test CASE\r
-anew test-case\r
-: TCASE  ( N -- )\r
-       CASE\r
-       0 OF ." is zero" ENDOF\r
-       1 OF\r
-               2 choose\r
-               CASE\r
-               0 OF ." chose zero" ENDOF\r
-               1 OF ." chose one" ENDOF\r
-               [ .s cr ." of-depth = " of-depth @ . cr ]\r
-               ENDCASE\r
-       ENDOF\r
-       [ .s cr ." of-depth = " of-depth @ . cr ]\r
-       ENDCASE\r
-;\r
+\ test CASE
+anew test-case
+: TCASE  ( N -- )
+    CASE
+    0 OF ." is zero" ENDOF
+    1 OF
+        2 choose
+        CASE
+        0 OF ." chose zero" ENDOF
+        1 OF ." chose one" ENDOF
+        [ .s cr ." of-depth = " of-depth @ . cr ]
+        ENDCASE
+    ENDOF
+    [ .s cr ." of-depth = " of-depth @ . cr ]
+    ENDCASE
+;

diff --git a/fth/t_corex.fth b/fth/t_corex.fth
index d747941..33103f4 100644 (file)
--- a/fth/t_corex.fth
+++ b/fth/t_corex.fth
@@ -1,226 +1,226 @@
-\ @(#) t_corex.fth 98/03/16 1.2\r
-\ Test ANS Forth Core Extensions\r
-\\r
-\ Copyright 1994 3DO, Phil Burk\r
-\r
-INCLUDE? }T{  t_tools.fth\r
-\r
-ANEW TASK-T_COREX.FTH\r
-\r
-DECIMAL\r
-\r
-\ STUB because missing definition in pForth - FIXME\r
-: SAVE-INPUT ;\r
-: RESTORE-INPUT -1 ;\r
-\r
-TEST{\r
-\r
-\ ==========================================================\r
-T{ 1 2 3 }T{ 1 2 3 }T\r
-\r
-\  ----------------------------------------------------- .(\r
-T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T\r
-\r
-CR .(     1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR\r
-\r
-T{ .( )   987   .( TEST NULL STRING IN .( ) CR }T{ 987 }T\r
-\r
-\  ----------------------------------------------------- 0<>\r
-T{ 5 0<> }T{ TRUE }T\r
-T{ 0 0<> }T{ 0 }T\r
-T{ -1000 0<> }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- 2>R 2R> 2R@\r
-: T2>R  ( -- .... )\r
-       17\r
-       20 5 2>R\r
-       19\r
-       2R@\r
-       37\r
-       2R>\r
-\ 2>R should be the equivalent of SWAP >R >R so this next construct\r
-\ should reduce to a SWAP.\r
-       88 77 2>R R> R>\r
-;\r
-T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T\r
-\r
-\  ----------------------------------------------------- :NONAME\r
-T{ :NONAME  100 50 + ; EXECUTE }T{ 150 }T\r
-\r
-\  ----------------------------------------------------- <>\r
-T{ 12345 12305 <> }T{ TRUE }T\r
-T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T\r
-\r
-\  ----------------------------------------------------- ?DO\r
-: T?DO  ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;\r
-T{ 0 T?DO }T{ 0 }T\r
-T{ 4 T?DO }T{ 10 }T\r
-\r
-\  ----------------------------------------------------- AGAIN\r
-: T.AGAIN  ( n --  )\r
-       BEGIN\r
-               DUP .\r
-               DUP 6 < IF EXIT THEN\r
-               1-\r
-       AGAIN\r
-;\r
-T{ 10 T.AGAIN CR }T{ 5 }T\r
-\r
-\  ----------------------------------------------------- C"\r
-: T.C"  ( -- $STRING )\r
-       C" x5&"\r
-;\r
-T{ T.C"  C@  }T{ 3 }T\r
-T{ T.C"  COUNT DROP C@  }T{ CHAR x }T\r
-T{ T.C"  COUNT DROP CHAR+ C@ }T{  CHAR 5 }T\r
-T{ T.C"  COUNT DROP 2 CHARS + C@  }T{ CHAR & }T\r
-\r
-\  ----------------------------------------------------- CASE\r
-: T.CASE  ( N -- )\r
-       CASE\r
-               1 OF 101 ENDOF\r
-               27 OF 892 ENDOF\r
-               941 SWAP \ default\r
-       ENDCASE\r
-;\r
-T{ 1 T.CASE }T{ 101 }T\r
-T{ 27 T.CASE }T{ 892 }T\r
-T{ 49 T.CASE }T{ 941 }T\r
-\r
-\  ----------------------------------------------------- COMPILE,\r
-: COMPILE.SWAP    ['] SWAP COMPILE, ; IMMEDIATE\r
-: T.COMPILE,\r
-       19 20 27 COMPILE.SWAP 39\r
-;\r
-T{ T.COMPILE, }T{ 19 27 20 39 }T\r
-\r
-\  ----------------------------------------------------- CONVERT\r
-: T.CONVERT\r
-       0 S>D  S" 1234xyz" DROP CONVERT\r
-       >R\r
-       D>S\r
-       R> C@\r
-;\r
-T{ T.CONVERT }T{ 1234 CHAR x }T\r
-\r
-\  ----------------------------------------------------- ERASE\r
-: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
-       0 ?DO I C, LOOP\r
-;\r
-CREATE T-ERASE-DATA   64 T.COMMA.SEQ\r
-T{ T-ERASE-DATA 8 + C@ }T{ 8 }T\r
-T{ T-ERASE-DATA 7 + 3 ERASE\r
-T{ T-ERASE-DATA 6 + C@ }T{ 6 }T\r
-T{ T-ERASE-DATA 7 + C@ }T{ 0 }T\r
-T{ T-ERASE-DATA 8 + C@ }T{ 0 }T\r
-T{ T-ERASE-DATA 9 + C@ }T{ 0 }T\r
-T{ T-ERASE-DATA 10 + C@ }T{ 10 }T\r
-\r
-\  ----------------------------------------------------- FALSE\r
-T{ FALSE }T{ 0 }T\r
-\r
-\  ----------------------------------------------------- HEX\r
-T{ HEX 10 DECIMAL }T{ 16 }T\r
-\r
-\  ----------------------------------------------------- MARKER\r
-: INDIC?  ( <name> -- ifInDic , is the following word defined? )\r
-       bl word find\r
-       swap drop 0= 0=\r
-;\r
-create FOOBAR\r
-MARKER MYMARK  \ create word that forgets itself\r
-create GOOFBALL\r
-MYMARK\r
-T{ indic? foobar  indic? mymark indic? goofball }T{ true false false }T\r
-\r
-\  ----------------------------------------------------- NIP\r
-T{ 33 44 55 NIP  }T{ 33 55 }T\r
-\r
-\  ----------------------------------------------------- PARSE\r
-: T.PARSE  ( char <string>char -- addr num )\r
-       PARSE\r
-       >R  \ save length\r
-       PAD R@ CMOVE  \ move string to pad\r
-       PAD R>\r
-;\r
-T{ CHAR % T.PARSE wxyz% SWAP C@ }T{  4  CHAR w }T\r
-\r
-\  ----------------------------------------------------- PICK\r
-T{ 13 12 11 10 2 PICK  }T{ 13 12 11 10 12 }T\r
-\r
-\  ----------------------------------------------------- QUERY\r
-T{ ' QUERY 0<> }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- REFILL\r
-T{ ' REFILL 0<> }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- RESTORE-INPUT\r
-T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T  \ EXPECTED FAILURE\r
-\r
-\  ----------------------------------------------------- ROLL\r
-T{ 15 14 13 12 11 10 0 ROLL  }T{  15 14 13 12 11 10 }T\r
-T{ 15 14 13 12 11 10 1 ROLL  }T{  15 14 13 12 10 11 }T\r
-T{ 15 14 13 12 11 10 2 ROLL  }T{  15 14 13 11 10 12 }T\r
-T{ 15 14 13 12 11 10 3 ROLL  }T{  15 14 12 11 10 13 }T\r
-T{ 15 14 13 12 11 10 4 ROLL  }T{  15 13 12 11 10 14 }T\r
-\r
-\  ----------------------------------------------------- SOURCE-ID\r
-T{ SOURCE-ID 0<> }T{ TRUE }T\r
-T{ : T.SOURCE-ID  S" SOURCE-ID" EVALUATE  ;   T.SOURCE-ID }T{ -1 }T\r
-\r
-\  ----------------------------------------------------- SPAN\r
-T{ ' SPAN 0<>  }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- TO VALUE\r
-333 VALUE  MY-VALUE\r
-T{ MY-VALUE }T{ 333 }T\r
-T{ 1000 TO MY-VALUE   MY-VALUE }T{ 1000 }T\r
-: TEST.VALUE  ( -- 19 100 )\r
-       100 TO MY-VALUE\r
-       19\r
-       MY-VALUE\r
-;\r
-T{ TEST.VALUE }T{ 19 100 }T\r
-\r
-\  ----------------------------------------------------- TRUE\r
-T{ TRUE }T{ 0 0= }T\r
-\r
-\  ----------------------------------------------------- TUCK\r
-T{ 44 55 66 TUCK }T{ 44 66 55 66 }T\r
-\r
-\  ----------------------------------------------------- U.R\r
-HEX CR .(     ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR\r
-ABCD4321 C U.R CR DECIMAL\r
-\r
-\  ----------------------------------------------------- U>\r
-T{ -5 3 U> }T{ TRUE }T\r
-T{ 10 8 U> }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- UNUSED\r
-T{ UNUSED 0> }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- WITHIN\r
-T{  4  5 10 WITHIN }T{ 0 }T\r
-T{  5  5 10 WITHIN }T{ TRUE }T\r
-T{  9  5 10 WITHIN }T{ TRUE }T\r
-T{ 10  5 10 WITHIN }T{ 0 }T\r
-\r
-T{  4  10 5 WITHIN }T{ TRUE }T\r
-T{  5  10 5 WITHIN }T{ 0 }T\r
-T{  9  10 5 WITHIN }T{ 0 }T\r
-T{ 10  10 5 WITHIN }T{ TRUE }T\r
-\r
-T{  -6  -5 10 WITHIN }T{ 0 }T\r
-T{  -5  -5 10 WITHIN    }T{ TRUE }T\r
-T{  9  -5 10 WITHIN    }T{ TRUE }T\r
-T{ 10  -5 10 WITHIN }T{ 0 }T\r
-\r
-\r
-\  ----------------------------------------------------- [COMPILE]\r
-: T.[COMPILE].IF  [COMPILE] IF ; IMMEDIATE\r
-: T.[COMPILE]  40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;\r
-T{ T.[COMPILE] }T{ TRUE }T\r
-\r
-\  ----------------------------------------------------- \\r
-}TEST\r
-\r
+\ @(#) t_corex.fth 98/03/16 1.2
+\ Test ANS Forth Core Extensions
+\
+\ Copyright 1994 3DO, Phil Burk
+
+INCLUDE? }T{  t_tools.fth
+
+ANEW TASK-T_COREX.FTH
+
+DECIMAL
+
+\ STUB because missing definition in pForth - FIXME
+: SAVE-INPUT ;
+: RESTORE-INPUT -1 ;
+
+TEST{
+
+\ ==========================================================
+T{ 1 2 3 }T{ 1 2 3 }T
+
+\  ----------------------------------------------------- .(
+T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T
+
+CR .(     1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR
+
+T{ .( )   987   .( TEST NULL STRING IN .( ) CR }T{ 987 }T
+
+\  ----------------------------------------------------- 0<>
+T{ 5 0<> }T{ TRUE }T
+T{ 0 0<> }T{ 0 }T
+T{ -1000 0<> }T{ TRUE }T
+
+\  ----------------------------------------------------- 2>R 2R> 2R@
+: T2>R  ( -- .... )
+    17
+    20 5 2>R
+    19
+    2R@
+    37
+    2R>
+\ 2>R should be the equivalent of SWAP >R >R so this next construct
+\ should reduce to a SWAP.
+    88 77 2>R R> R>
+;
+T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T
+
+\  ----------------------------------------------------- :NONAME
+T{ :NONAME  100 50 + ; EXECUTE }T{ 150 }T
+
+\  ----------------------------------------------------- <>
+T{ 12345 12305 <> }T{ TRUE }T
+T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T
+
+\  ----------------------------------------------------- ?DO
+: T?DO  ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;
+T{ 0 T?DO }T{ 0 }T
+T{ 4 T?DO }T{ 10 }T
+
+\  ----------------------------------------------------- AGAIN
+: T.AGAIN  ( n --  )
+    BEGIN
+        DUP .
+        DUP 6 < IF EXIT THEN
+        1-
+    AGAIN
+;
+T{ 10 T.AGAIN CR }T{ 5 }T
+
+\  ----------------------------------------------------- C"
+: T.C"  ( -- $STRING )
+    C" x5&"
+;
+T{ T.C"  C@  }T{ 3 }T
+T{ T.C"  COUNT DROP C@  }T{ CHAR x }T
+T{ T.C"  COUNT DROP CHAR+ C@ }T{  CHAR 5 }T
+T{ T.C"  COUNT DROP 2 CHARS + C@  }T{ CHAR & }T
+
+\  ----------------------------------------------------- CASE
+: T.CASE  ( N -- )
+    CASE
+        1 OF 101 ENDOF
+        27 OF 892 ENDOF
+        941 SWAP \ default
+    ENDCASE
+;
+T{ 1 T.CASE }T{ 101 }T
+T{ 27 T.CASE }T{ 892 }T
+T{ 49 T.CASE }T{ 941 }T
+
+\  ----------------------------------------------------- COMPILE,
+: COMPILE.SWAP    ['] SWAP COMPILE, ; IMMEDIATE
+: T.COMPILE,
+    19 20 27 COMPILE.SWAP 39
+;
+T{ T.COMPILE, }T{ 19 27 20 39 }T
+
+\  ----------------------------------------------------- CONVERT
+: T.CONVERT
+    0 S>D  S" 1234xyz" DROP CONVERT
+    >R
+    D>S
+    R> C@
+;
+T{ T.CONVERT }T{ 1234 CHAR x }T
+
+\  ----------------------------------------------------- ERASE
+: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )
+    0 ?DO I C, LOOP
+;
+CREATE T-ERASE-DATA   64 T.COMMA.SEQ
+T{ T-ERASE-DATA 8 + C@ }T{ 8 }T
+T{ T-ERASE-DATA 7 + 3 ERASE
+T{ T-ERASE-DATA 6 + C@ }T{ 6 }T
+T{ T-ERASE-DATA 7 + C@ }T{ 0 }T
+T{ T-ERASE-DATA 8 + C@ }T{ 0 }T
+T{ T-ERASE-DATA 9 + C@ }T{ 0 }T
+T{ T-ERASE-DATA 10 + C@ }T{ 10 }T
+
+\  ----------------------------------------------------- FALSE
+T{ FALSE }T{ 0 }T
+
+\  ----------------------------------------------------- HEX
+T{ HEX 10 DECIMAL }T{ 16 }T
+
+\  ----------------------------------------------------- MARKER
+: INDIC?  ( <name> -- ifInDic , is the following word defined? )
+    bl word find
+    swap drop 0= 0=
+;
+create FOOBAR
+MARKER MYMARK  \ create word that forgets itself
+create GOOFBALL
+MYMARK
+T{ indic? foobar  indic? mymark indic? goofball }T{ true false false }T
+
+\  ----------------------------------------------------- NIP
+T{ 33 44 55 NIP  }T{ 33 55 }T
+
+\  ----------------------------------------------------- PARSE
+: T.PARSE  ( char <string>char -- addr num )
+    PARSE
+    >R  \ save length
+    PAD R@ CMOVE  \ move string to pad
+    PAD R>
+;
+T{ CHAR % T.PARSE wxyz% SWAP C@ }T{  4  CHAR w }T
+
+\  ----------------------------------------------------- PICK
+T{ 13 12 11 10 2 PICK  }T{ 13 12 11 10 12 }T
+
+\  ----------------------------------------------------- QUERY
+T{ ' QUERY 0<> }T{ TRUE }T
+
+\  ----------------------------------------------------- REFILL
+T{ ' REFILL 0<> }T{ TRUE }T
+
+\  ----------------------------------------------------- RESTORE-INPUT
+T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T  \ EXPECTED FAILURE
+
+\  ----------------------------------------------------- ROLL
+T{ 15 14 13 12 11 10 0 ROLL  }T{  15 14 13 12 11 10 }T
+T{ 15 14 13 12 11 10 1 ROLL  }T{  15 14 13 12 10 11 }T
+T{ 15 14 13 12 11 10 2 ROLL  }T{  15 14 13 11 10 12 }T
+T{ 15 14 13 12 11 10 3 ROLL  }T{  15 14 12 11 10 13 }T
+T{ 15 14 13 12 11 10 4 ROLL  }T{  15 13 12 11 10 14 }T
+
+\  ----------------------------------------------------- SOURCE-ID
+T{ SOURCE-ID 0<> }T{ TRUE }T
+T{ : T.SOURCE-ID  S" SOURCE-ID" EVALUATE  ;   T.SOURCE-ID }T{ -1 }T
+
+\  ----------------------------------------------------- SPAN
+T{ ' SPAN 0<>  }T{ TRUE }T
+
+\  ----------------------------------------------------- TO VALUE
+333 VALUE  MY-VALUE
+T{ MY-VALUE }T{ 333 }T
+T{ 1000 TO MY-VALUE   MY-VALUE }T{ 1000 }T
+: TEST.VALUE  ( -- 19 100 )
+    100 TO MY-VALUE
+    19
+    MY-VALUE
+;
+T{ TEST.VALUE }T{ 19 100 }T
+
+\  ----------------------------------------------------- TRUE
+T{ TRUE }T{ 0 0= }T
+
+\  ----------------------------------------------------- TUCK
+T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
+
+\  ----------------------------------------------------- U.R
+HEX CR .(     ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
+ABCD4321 C U.R CR DECIMAL
+
+\  ----------------------------------------------------- U>
+T{ -5 3 U> }T{ TRUE }T
+T{ 10 8 U> }T{ TRUE }T
+
+\  ----------------------------------------------------- UNUSED
+T{ UNUSED 0> }T{ TRUE }T
+
+\  ----------------------------------------------------- WITHIN
+T{  4  5 10 WITHIN }T{ 0 }T
+T{  5  5 10 WITHIN }T{ TRUE }T
+T{  9  5 10 WITHIN }T{ TRUE }T
+T{ 10  5 10 WITHIN }T{ 0 }T
+
+T{  4  10 5 WITHIN }T{ TRUE }T
+T{  5  10 5 WITHIN }T{ 0 }T
+T{  9  10 5 WITHIN }T{ 0 }T
+T{ 10  10 5 WITHIN }T{ TRUE }T
+
+T{  -6  -5 10 WITHIN }T{ 0 }T
+T{  -5  -5 10 WITHIN    }T{ TRUE }T
+T{  9  -5 10 WITHIN    }T{ TRUE }T
+T{ 10  -5 10 WITHIN }T{ 0 }T
+
+
+\  ----------------------------------------------------- [COMPILE]
+: T.[COMPILE].IF  [COMPILE] IF ; IMMEDIATE
+: T.[COMPILE]  40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;
+T{ T.[COMPILE] }T{ TRUE }T
+
+\  ----------------------------------------------------- \
+}TEST
+

diff --git a/fth/t_floats.fth b/fth/t_floats.fth
index 03d9ba1..05612be 100644 (file)
--- a/fth/t_floats.fth
+++ b/fth/t_floats.fth
@@ -1,134 +1,134 @@
-\ @(#) t_floats.fth 98/02/26 1.1 17:46:04\r
-\ Test ANS Forth FLOAT words.\r
-\\r
-\ Copyright 1994 3DO, Phil Burk\r
-\r
-INCLUDE? }T{  t_tools.fth\r
-\r
-ANEW TASK-T_FLOATS.FTH\r
-\r
-DECIMAL\r
-3.14159265 fconstant PI\r
-\r
-TEST{\r
-\ ==========================================================\r
-T{ 1 2 3 }T{ 1 2 3 }T\r
-\  ----------------------------------------------------- D>F F>D\r
-\ test some basic floating point <> integer conversion\r
-T{   4  0 D>F F>D  }T{   4  0 }T\r
-T{ 835  0 D>F F>D  }T{ 835  0 }T\r
-T{ -57 -1 D>F F>D  }T{ -57 -1 }T\r
-T{ 15 S>F 2 S>F F/ F>S }T{ 7 }T  \ 15.0/2.0 -> 7.5\r
-\r
-\  ----------------------------------------------------- input\r
-T{ 79.2 F>S }T{ 79 }T\r
-T{ 0.003 F>S }T{ 0 }T\r
-\r
-\ ------------------------------------------------------ F~\r
-T{  23.4  23.5  0.2   f~ }T{  true  }T\r
-T{  23.4  23.7  0.2   f~ }T{  false }T\r
-T{ 922.3 922.3  0.0   f~ }T{  true  }T\r
-T{ 922.3 922.31 0.0   f~ }T{  false }T\r
-T{   0.0   0.0  0.0   f~ }T{  true  }T\r
-T{   0.0  -0.0  0.0   f~ }T{  false }T\r
-T{  50.0  51.0 -0.02  f~ }T{  true  }T\r
-T{  50.0  51.0 -0.002 f~ }T{  false }T\r
-T{ 500.0 510.0 -0.02  f~ }T{  true  }T\r
-T{ 500.0 510.0 -0.002 f~ }T{  false }T\r
-\r
-\ convert number to text representation and then back to float\r
-: T_F. ( -- ok? ) ( r ftol -f- )\r
-       fover (f.) >float fswap f~\r
-       AND\r
-;\r
-: T_FS. ( -- ok? ) ( r ftol -f- )\r
-       fover (fs.) >float fswap f~\r
-       AND\r
-;\r
-: T_FE. ( -- ok? ) ( r ftol -f- )\r
-       fover (fe.) >float fswap f~\r
-       AND\r
-;\r
-\r
-: T_FG. ( -- ok? ) ( r ftol -f- )\r
-       fover (f.) >float fswap f~\r
-       AND\r
-;\r
-\r
-: T_F>D ( -- ok? ) ( r ftol -f- )\r
-       fover f>d d>f fswap f~\r
-;\r
-\r
-T{ 0.0  0.00001 T_F.  }T{  true  }T\r
-T{ 0.0  0.00001 T_FS.  }T{  true  }T\r
-T{ 0.0  0.00001 T_FE.  }T{  true  }T\r
-T{ 0.0  0.00001 T_FG.  }T{  true  }T\r
-T{ 0.0  0.00001 T_F>D  }T{  true  }T\r
-\r
-T{ 12.34  -0.0001 T_F.  }T{  true  }T\r
-T{ 12.34  -0.0001 T_FS.  }T{  true  }T\r
-T{ 12.34  -0.0001 T_FE.  }T{  true  }T\r
-T{ 12.34  -0.0001 T_FG.  }T{  true  }T\r
-T{ 1234.0  -0.0001 T_F>D  }T{  true  }T\r
-\r
-T{ 2345 S>F  79 S>F  F/  -0.0001 T_F.  }T{  true  }T\r
-T{ 511 S>F  -294 S>F  F/  -0.0001 T_F.  }T{  true  }T\r
-\r
-: T.SERIES { N matchCFA | flag -- ok? } (  fstart fmult -f- )\r
-       fswap  ( -- fmult fstart )\r
-       true -> flag\r
-       N 0\r
-       ?DO\r
-               fdup -0.0001 matchCFA execute not\r
-               IF\r
-                       false -> flag\r
-                       ." T_F_SERIES failed for " i . fdup f. cr\r
-                       leave\r
-               THEN\r
-\              i . fdup f. cr\r
-               fover f*\r
-       LOOP\r
-       matchCFA >name id. ."  T.SERIES final = " fs. cr\r
-       flag\r
-;\r
-\r
-: T.SERIES_F.    ['] t_f.  t.series ;\r
-: T.SERIES_FS.   ['] t_fs. t.series ;\r
-: T.SERIES_FG.   ['] t_fg. t.series ;\r
-: T.SERIES_FE.   ['] t_fe. t.series ;\r
-: T.SERIES_F>D   ['] t_f>d t.series ;\r
-\r
-T{  1.0     1.3       150 t.series_f.    }T{  true  }T\r
-T{  1.0    -1.3       150 t.series_f.    }T{  true  }T\r
-T{  2.3456789 1.3719  150 t.series_f.    }T{  true  }T\r
-\r
-T{  3000.0  1.298     120 t.series_f>d   }T{  true  }T\r
-\r
-T{  1.2     1.27751   150 t.series_fs.   }T{  true  }T\r
-T{  7.43    0.812255  200 t.series_fs.   }T{  true  }T\r
-\r
-T{  1.195   1.30071   150 t.series_fe.   }T{  true  }T\r
-T{  5.913   0.80644   200 t.series_fe.   }T{  true  }T\r
-\r
-T{  1.395   1.55071   120 t.series_fe.   }T{  true  }T\r
-T{  5.413   0.83644   160 t.series_fe.   }T{  true  }T\r
-\r
-\  ----------------------------------------------------- FABS\r
-T{  0.0   FABS  0.0         0.00001 F~    }T{  true  }T\r
-T{  7.0   FABS  7.0         0.00001 F~    }T{  true  }T\r
-T{ -47.3  FABS  47.3        0.00001 F~    }T{  true  }T\r
-\r
-\  ----------------------------------------------------- FSQRT\r
-T{  49.0  FSQRT  7.0       -0.0001 F~    }T{  true  }T\r
-T{  2.0   FSQRT  1.414214  -0.0001 F~    }T{  true  }T\r
-\r
-\  ----------------------------------------------------- FSIN\r
-T{  0.0   FSIN  0.0         0.00001 F~    }T{  true  }T\r
-T{  PI    FSIN  0.0         0.00001 F~    }T{  true  }T\r
-T{  PI 2.0 F*  FSIN   0.0   0.00001 F~    }T{  true  }T\r
-T{  PI 0.5 F*  FSIN   1.0   0.00001 F~    }T{  true  }T\r
-T{  PI 6.0 F/  FSIN   0.5   0.00001 F~    }T{  true  }T\r
-\r
-\  ----------------------------------------------------- \\r
-}TEST\r
-\r
+\ @(#) t_floats.fth 98/02/26 1.1 17:46:04
+\ Test ANS Forth FLOAT words.
+\
+\ Copyright 1994 3DO, Phil Burk
+
+INCLUDE? }T{  t_tools.fth
+
+ANEW TASK-T_FLOATS.FTH
+
+DECIMAL
+3.14159265 fconstant PI
+
+TEST{
+\ ==========================================================
+T{ 1 2 3 }T{ 1 2 3 }T
+\  ----------------------------------------------------- D>F F>D
+\ test some basic floating point <> integer conversion
+T{   4  0 D>F F>D  }T{   4  0 }T
+T{ 835  0 D>F F>D  }T{ 835  0 }T
+T{ -57 -1 D>F F>D  }T{ -57 -1 }T
+T{ 15 S>F 2 S>F F/ F>S }T{ 7 }T  \ 15.0/2.0 -> 7.5
+
+\  ----------------------------------------------------- input
+T{ 79.2 F>S }T{ 79 }T
+T{ 0.003 F>S }T{ 0 }T
+
+\ ------------------------------------------------------ F~
+T{  23.4  23.5  0.2   f~ }T{  true  }T
+T{  23.4  23.7  0.2   f~ }T{  false }T
+T{ 922.3 922.3  0.0   f~ }T{  true  }T
+T{ 922.3 922.31 0.0   f~ }T{  false }T
+T{   0.0   0.0  0.0   f~ }T{  true  }T
+T{   0.0  -0.0  0.0   f~ }T{  false }T
+T{  50.0  51.0 -0.02  f~ }T{  true  }T
+T{  50.0  51.0 -0.002 f~ }T{  false }T
+T{ 500.0 510.0 -0.02  f~ }T{  true  }T
+T{ 500.0 510.0 -0.002 f~ }T{  false }T
+
+\ convert number to text representation and then back to float
+: T_F. ( -- ok? ) ( r ftol -f- )
+    fover (f.) >float fswap f~
+    AND
+;
+: T_FS. ( -- ok? ) ( r ftol -f- )
+    fover (fs.) >float fswap f~
+    AND
+;
+: T_FE. ( -- ok? ) ( r ftol -f- )
+    fover (fe.) >float fswap f~
+    AND
+;
+
+: T_FG. ( -- ok? ) ( r ftol -f- )
+    fover (f.) >float fswap f~
+    AND
+;
+
+: T_F>D ( -- ok? ) ( r ftol -f- )
+    fover f>d d>f fswap f~
+;
+
+T{ 0.0  0.00001 T_F.  }T{  true  }T
+T{ 0.0  0.00001 T_FS.  }T{  true  }T
+T{ 0.0  0.00001 T_FE.  }T{  true  }T
+T{ 0.0  0.00001 T_FG.  }T{  true  }T
+T{ 0.0  0.00001 T_F>D  }T{  true  }T
+
+T{ 12.34  -0.0001 T_F.  }T{  true  }T
+T{ 12.34  -0.0001 T_FS.  }T{  true  }T
+T{ 12.34  -0.0001 T_FE.  }T{  true  }T
+T{ 12.34  -0.0001 T_FG.  }T{  true  }T
+T{ 1234.0  -0.0001 T_F>D  }T{  true  }T
+
+T{ 2345 S>F  79 S>F  F/  -0.0001 T_F.  }T{  true  }T
+T{ 511 S>F  -294 S>F  F/  -0.0001 T_F.  }T{  true  }T
+
+: T.SERIES { N matchCFA | flag -- ok? } (  fstart fmult -f- )
+    fswap  ( -- fmult fstart )
+    true -> flag
+    N 0
+    ?DO
+        fdup -0.0001 matchCFA execute not
+        IF
+            false -> flag
+            ." T_F_SERIES failed for " i . fdup f. cr
+            leave
+        THEN
+\       i . fdup f. cr
+        fover f*
+    LOOP
+    matchCFA >name id. ."  T.SERIES final = " fs. cr
+    flag
+;
+
+: T.SERIES_F.    ['] t_f.  t.series ;
+: T.SERIES_FS.   ['] t_fs. t.series ;
+: T.SERIES_FG.   ['] t_fg. t.series ;
+: T.SERIES_FE.   ['] t_fe. t.series ;
+: T.SERIES_F>D   ['] t_f>d t.series ;
+
+T{  1.0     1.3       150 t.series_f.    }T{  true  }T
+T{  1.0    -1.3       150 t.series_f.    }T{  true  }T
+T{  2.3456789 1.3719  150 t.series_f.    }T{  true  }T
+
+T{  3000.0  1.298     120 t.series_f>d   }T{  true  }T
+
+T{  1.2     1.27751   150 t.series_fs.   }T{  true  }T
+T{  7.43    0.812255  200 t.series_fs.   }T{  true  }T
+
+T{  1.195   1.30071   150 t.series_fe.   }T{  true  }T
+T{  5.913   0.80644   200 t.series_fe.   }T{  true  }T
+
+T{  1.395   1.55071   120 t.series_fe.   }T{  true  }T
+T{  5.413   0.83644   160 t.series_fe.   }T{  true  }T
+
+\  ----------------------------------------------------- FABS
+T{  0.0   FABS  0.0         0.00001 F~    }T{  true  }T
+T{  7.0   FABS  7.0         0.00001 F~    }T{  true  }T
+T{ -47.3  FABS  47.3        0.00001 F~    }T{  true  }T
+
+\  ----------------------------------------------------- FSQRT
+T{  49.0  FSQRT  7.0       -0.0001 F~    }T{  true  }T
+T{  2.0   FSQRT  1.414214  -0.0001 F~    }T{  true  }T
+
+\  ----------------------------------------------------- FSIN
+T{  0.0   FSIN  0.0         0.00001 F~    }T{  true  }T
+T{  PI    FSIN  0.0         0.00001 F~    }T{  true  }T
+T{  PI 2.0 F*  FSIN   0.0   0.00001 F~    }T{  true  }T
+T{  PI 0.5 F*  FSIN   1.0   0.00001 F~    }T{  true  }T
+T{  PI 6.0 F/  FSIN   0.5   0.00001 F~    }T{  true  }T
+
+\  ----------------------------------------------------- \
+}TEST
+

diff --git a/fth/t_include.fth b/fth/t_include.fth
index db7e646..d7ba7c2 100644 (file)
--- a/fth/t_include.fth
+++ b/fth/t_include.fth
@@ -1,18 +1,18 @@
-\ Test INCLUDE errors.\r
-\\r
-\ Copyright 2001Phil Burk\r
-\r
-include? }T{  t_tools.fth\r
-\r
-marker task-t_string.fth\r
-\r
-decimal\r
-\r
-: F_UNDEF " t_load_undef.fth" ;\r
-\r
-test{\r
-\r
-T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T\r
-\r
-       \r
-}test\r
+\ Test INCLUDE errors.
+\
+\ Copyright 2001Phil Burk
+
+include? }T{  t_tools.fth
+
+marker task-t_string.fth
+
+decimal
+
+: F_UNDEF " t_load_undef.fth" ;
+
+test{
+
+T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T
+
+
+}test

diff --git a/fth/t_load.fth b/fth/t_load.fth
index 8efadc3..9475eff 100644 (file)
--- a/fth/t_load.fth
+++ b/fth/t_load.fth
@@ -1,7 +1,7 @@
-\ Test nested INCLUDE errors.\r
-\\r
-\ Copyright 2001Phil Burk\r
-\r
-\ include t_load_undef.fth\r
-\ include t_load_semi.fth\r
-include t_load_defer.fth\r
+\ Test nested INCLUDE errors.
+\
+\ Copyright 2001Phil Burk
+
+\ include t_load_undef.fth
+\ include t_load_semi.fth
+include t_load_defer.fth

diff --git a/fth/t_load_defer.fth b/fth/t_load_defer.fth
index 01b4e8b..c5e79e9 100644 (file)
--- a/fth/t_load_defer.fth
+++ b/fth/t_load_defer.fth
@@ -1,5 +1,5 @@
-\ Test INCLUDE errors.\r
-\r
-what's dup >name id.  \ but DUP is not deferred!\r
-\r
-We should never reach this text.\r
+\ Test INCLUDE errors.
+
+what's dup >name id.  \ but DUP is not deferred!
+
+We should never reach this text.

diff --git a/fth/t_load_pairs.fth b/fth/t_load_pairs.fth
index b4b93c7..ec41b73 100644 (file)
--- a/fth/t_load_pairs.fth
+++ b/fth/t_load_pairs.fth
@@ -1,5 +1,5 @@
-\ Test INCLUDE errors.\r
-\r
-: T.LOAD.PAIRS\r
-       10 0 DO i . THEN\r
-;\r
+\ Test INCLUDE errors.
+
+: T.LOAD.PAIRS
+    10 0 DO i . THEN
+;

diff --git a/fth/t_load_semi.fth b/fth/t_load_semi.fth
index 83bdd26..4aa3e77 100644 (file)
--- a/fth/t_load_semi.fth
+++ b/fth/t_load_semi.fth
@@ -1,6 +1,6 @@
-\ Test INCLUDE errors.\r
-\r
-: T.LOAD.PAIRS\r
-       1 IF\r
-       ." hello" cr\r
-; \ missing a THEN\r
+\ Test INCLUDE errors.
+
+: T.LOAD.PAIRS
+    1 IF
+    ." hello" cr
+; \ missing a THEN

diff --git a/fth/t_load_undef.fth b/fth/t_load_undef.fth
index 8923a47..2c3c653 100644 (file)
--- a/fth/t_load_undef.fth
+++ b/fth/t_load_undef.fth
@@ -1,5 +1,5 @@
-\ Test INCLUDE errors.\r
-\r
-: T.LOAD.UNDEF\r
-       23 45 swap BADWORD \ reference an undefined word!\r
-;\r
+\ Test INCLUDE errors.
+
+: T.LOAD.UNDEF
+    23 45 swap BADWORD \ reference an undefined word!
+;

diff --git a/fth/t_locals.fth b/fth/t_locals.fth
index aa6e03d..5cec9e0 100644 (file)
--- a/fth/t_locals.fth
+++ b/fth/t_locals.fth
@@ -1,52 +1,52 @@
-\ @(#) t_locals.fth 97/01/28 1.1\r
-\ Test PForth LOCAL variables.\r
-\\r
-\ Copyright 1996 3DO, Phil Burk\r
-\r
-include? }T{  t_tools.fth\r
-\r
-anew task-t_locals.fth\r
-decimal\r
-\r
-test{\r
-\r
-\ test value and locals\r
-T{ 333 value  my-value   my-value }T{  333 }T\r
-T{ 1000 -> my-value   my-value }T{ 1000 }T\r
-T{ 35 +-> my-value   my-value }T{ 1035 }T\r
-: test.value  ( -- ok )\r
-       100 -> my-value\r
-       my-value 100 =\r
-       47 +-> my-value\r
-       my-value 147 = AND\r
-;\r
-T{ test.value }T{ TRUE }T\r
-\r
-\ test locals in a word\r
-: test.locs  { aa bb | cc -- ok }\r
-       cc 0=\r
-       aa bb + -> cc\r
-       aa bb +   cc = AND\r
-       aa -> cc\r
-       bb +->  cc\r
-       aa bb +   cc = AND\r
-;\r
-\r
-T{ 200 59 test.locs }T{  TRUE }T\r
-\r
-.( Test warning when no locals defined.) cr\r
-: loc.nonames { -- } 1234 ;\r
-T{ loc.nonames }T{ 1234 }T\r
-\r
-\ try to put EOLs and comments in variable list\r
-: calc.area {\r
-       width    \ horizontal dimension\r
-       height   \ vertical dimension\r
-       -- area , calculate area of a rectangle }\r
-       width height *\r
-;\r
-\r
-T{ 5 20 calc.area }T{ 100 }T\r
-\r
-}test\r
-\r
+\ @(#) t_locals.fth 97/01/28 1.1
+\ Test PForth LOCAL variables.
+\
+\ Copyright 1996 3DO, Phil Burk
+
+include? }T{  t_tools.fth
+
+anew task-t_locals.fth
+decimal
+
+test{
+
+\ test value and locals
+T{ 333 value  my-value   my-value }T{  333 }T
+T{ 1000 -> my-value   my-value }T{ 1000 }T
+T{ 35 +-> my-value   my-value }T{ 1035 }T
+: test.value  ( -- ok )
+    100 -> my-value
+    my-value 100 =
+    47 +-> my-value
+    my-value 147 = AND
+;
+T{ test.value }T{ TRUE }T
+
+\ test locals in a word
+: test.locs  { aa bb | cc -- ok }
+    cc 0=
+    aa bb + -> cc
+    aa bb +   cc = AND
+    aa -> cc
+    bb +->  cc
+    aa bb +   cc = AND
+;
+
+T{ 200 59 test.locs }T{  TRUE }T
+
+.( Test warning when no locals defined.) cr
+: loc.nonames { -- } 1234 ;
+T{ loc.nonames }T{ 1234 }T
+
+\ try to put EOLs and comments in variable list
+: calc.area {
+    width    \ horizontal dimension
+    height   \ vertical dimension
+    -- area , calculate area of a rectangle }
+    width height *
+;
+
+T{ 5 20 calc.area }T{ 100 }T
+
+}test
+

diff --git a/fth/t_nolf.fth b/fth/t_nolf.fth
index 2ca7c1d..a9e2a9d 100644 (file)
--- a/fth/t_nolf.fth
+++ b/fth/t_nolf.fth
@@ -1,4 +1,4 @@
-\ Test behavior of pForth when line encountered with no EOF at end.\r
-\r
-." First Line of Two" cr\r
-." Second Line of Two" cr
\ No newline at end of file
+\ Test behavior of pForth when line encountered with no EOF at end.
+
+." First Line of Two" cr
+." Second Line of Two" cr

diff --git a/fth/t_strings.fth b/fth/t_strings.fth
index 4f48874..bd5e3e6 100644 (file)
--- a/fth/t_strings.fth
+++ b/fth/t_strings.fth
@@ -1,106 +1,106 @@
-\ @(#) t_strings.fth 97/12/10 1.1\r
-\ Test ANS Forth String Word Set\r
-\\r
-\ Copyright 1994 3DO, Phil Burk\r
-\r
-include? }T{  t_tools.fth\r
-\r
-marker task-t_string.fth\r
-\r
-decimal\r
-\r
-test{\r
-\r
-echo off\r
-\r
-\ ==========================================================\r
-\ test is.ok?\r
-T{ 1 2 3 }T{ 1 2 3 }T\r
-\r
-: STR1  S" Hello    " ;\r
-: STR2  S" Hello World" ;\r
-: STR3  S" " ;\r
-\r
-\  ----------------------------------------------------- -TRAILING\r
-T{ STR1 -TRAILING }T{ STR1 DROP 5 }T\r
-T{ STR2 -TRAILING }T{ STR2 }T\r
-T{ STR3 -TRAILING }T{ STR3 }T\r
-\r
-\  ----------------------------------------------------- /STRING\r
-T{ STR2  6  /STRING  }T{ STR2 DROP 6 CHARS +   STR2 NIP 6 -  }T\r
-\r
-\r
-\  ----------------------------------------------------- BLANK\r
-: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
-       0 ?DO I C, LOOP\r
-;\r
-CREATE T-BLANK-DATA   64 T.COMMA.SEQ\r
-T{ T-BLANK-DATA 8 + C@ }T{ 8 }T\r
-T-BLANK-DATA 7 + 3 BLANK\r
-T{ T-BLANK-DATA 6 + C@ }T{ 6 }T\r
-T{ T-BLANK-DATA 7 + C@ }T{ BL }T\r
-T{ T-BLANK-DATA 8 + C@ }T{ BL }T\r
-T{ T-BLANK-DATA 9 + C@ }T{ BL }T\r
-T{ T-BLANK-DATA 10 + C@ }T{ 10 }T\r
-FORGET T.COMMA.SEQ\r
-\r
-\  ----------------------------------------------------- CMOVE\r
-: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
-       0 ?DO I C, LOOP\r
-;\r
-CREATE T-BLANK-DATA   64 T.COMMA.SEQ\r
-T-BLANK-DATA 7 + T-BLANK-DATA 6 + 3 CMOVE\r
-T{ T-BLANK-DATA 5 + C@ }T{ 5 }T\r
-T{ T-BLANK-DATA 6 + C@ }T{ 7 }T\r
-T{ T-BLANK-DATA 7 + C@ }T{ 8 }T\r
-T{ T-BLANK-DATA 8 + C@ }T{ 9 }T\r
-T{ T-BLANK-DATA 9 + C@ }T{ 9 }T\r
-FORGET T.COMMA.SEQ\r
-\r
-\  ----------------------------------------------------- CMOVE>\r
-: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
-       0 ?DO I C, LOOP\r
-;\r
-CREATE T-BLANK-DATA   64 T.COMMA.SEQ\r
-T{ T-BLANK-DATA 6 + T-BLANK-DATA 7 + 3 CMOVE>\r
-T{ T-BLANK-DATA 5 + C@ }T{ 5 }T\r
-T{ T-BLANK-DATA 6 + C@ }T{ 6 }T\r
-T{ T-BLANK-DATA 7 + C@ }T{ 6 }T\r
-T{ T-BLANK-DATA 8 + C@ }T{ 7 }T\r
-T{ T-BLANK-DATA 9 + C@ }T{ 8 }T\r
-T{ T-BLANK-DATA 10 + C@ }T{ 10 }T\r
-FORGET T.COMMA.SEQ\r
-\r
-\  ----------------------------------------------------- COMPARE\r
-T{ : T.COMPARE.1 S" abcd" S" abcd"    compare ; t.compare.1 }T{   0 }T\r
-T{ : T.COMPARE.2 S" abcd" S" abcde"   compare ; t.compare.2 }T{  -1 }T\r
-T{ : T.COMPARE.3 S" abcdef" S" abcde" compare ; t.compare.3 }T{   1 }T\r
-T{ : T.COMPARE.4 S" abGd" S" abcde"   compare ; t.compare.4 }T{  -1 }T\r
-T{ : T.COMPARE.5 S" abcd" S" aXcde"   compare ; t.compare.5 }T{   1 }T\r
-T{ : T.COMPARE.6 S" abGd" S" abcd"    compare ; t.compare.6 }T{  -1 }T\r
-T{ : T.COMPARE.7 S" World" S" World"  compare ; t.compare.7 }T{   0 }T\r
-FORGET T.COMPARE.1\r
-\r
-\  ----------------------------------------------------- SEARCH\r
-: STR-SEARCH S" ABCDefghIJKL" ;\r
-T{ : T.SEARCH.1 STR-SEARCH S" ABCD" SEARCH ; T.SEARCH.1 }T{ STR-SEARCH TRUE }T\r
-T{ : T.SEARCH.2 STR-SEARCH S" efg"  SEARCH ; T.SEARCH.2 }T{\r
-        STR-SEARCH 4 - SWAP 4 CHARS + SWAP TRUE }T\r
-T{ : T.SEARCH.3 STR-SEARCH S" IJKL" SEARCH ; T.SEARCH.3 }T{\r
-        STR-SEARCH DROP 8 CHARS + 4 TRUE }T\r
-T{ : T.SEARCH.4 STR-SEARCH STR-SEARCH SEARCH ; T.SEARCH.4 }T{\r
-        STR-SEARCH  TRUE }T\r
-\r
-T{ : T.SEARCH.5 STR-SEARCH S" CDex" SEARCH ; T.SEARCH.5 }T{\r
-        STR-SEARCH  FALSE }T\r
-T{ : T.SEARCH.6 STR-SEARCH S" KLM" SEARCH ; T.SEARCH.6 }T{\r
-        STR-SEARCH  FALSE }T\r
-FORGET STR-SEARCH\r
-\r
-\  ----------------------------------------------------- SLITERAL\r
-CREATE FAKE-STRING  CHAR H C,   CHAR e C,  CHAR l C, CHAR l C, CHAR o C, \r
-ALIGN\r
-T{ : T.SLITERAL.1  [ FAKE-STRING 5 ] SLITERAL ; T.SLITERAL.1   FAKE-STRING 5 COMPARE\r
-        }T{ 0 }T\r
-       \r
-}test\r
+\ @(#) t_strings.fth 97/12/10 1.1
+\ Test ANS Forth String Word Set
+\
+\ Copyright 1994 3DO, Phil Burk
+
+include? }T{  t_tools.fth
+
+marker task-t_string.fth
+
+decimal
+
+test{
+
+echo off
+
+\ ==========================================================
+\ test is.ok?
+T{ 1 2 3 }T{ 1 2 3 }T
+
+: STR1  S" Hello    " ;
+: STR2  S" Hello World" ;
+: STR3  S" " ;
+
+\  ----------------------------------------------------- -TRAILING
+T{ STR1 -TRAILING }T{ STR1 DROP 5 }T
+T{ STR2 -TRAILING }T{ STR2 }T
+T{ STR3 -TRAILING }T{ STR3 }T
+
+\  ----------------------------------------------------- /STRING
+T{ STR2  6  /STRING  }T{ STR2 DROP 6 CHARS +   STR2 NIP 6 -  }T
+
+
+\  ----------------------------------------------------- BLANK
+: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )
+    0 ?DO I C, LOOP
+;
+CREATE T-BLANK-DATA   64 T.COMMA.SEQ
+T{ T-BLANK-DATA 8 + C@ }T{ 8 }T
+T-BLANK-DATA 7 + 3 BLANK
+T{ T-BLANK-DATA 6 + C@ }T{ 6 }T
+T{ T-BLANK-DATA 7 + C@ }T{ BL }T
+T{ T-BLANK-DATA 8 + C@ }T{ BL }T
+T{ T-BLANK-DATA 9 + C@ }T{ BL }T
+T{ T-BLANK-DATA 10 + C@ }T{ 10 }T
+FORGET T.COMMA.SEQ
+
+\  ----------------------------------------------------- CMOVE
+: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )
+    0 ?DO I C, LOOP
+;
+CREATE T-BLANK-DATA   64 T.COMMA.SEQ
+T-BLANK-DATA 7 + T-BLANK-DATA 6 + 3 CMOVE
+T{ T-BLANK-DATA 5 + C@ }T{ 5 }T
+T{ T-BLANK-DATA 6 + C@ }T{ 7 }T
+T{ T-BLANK-DATA 7 + C@ }T{ 8 }T
+T{ T-BLANK-DATA 8 + C@ }T{ 9 }T
+T{ T-BLANK-DATA 9 + C@ }T{ 9 }T
+FORGET T.COMMA.SEQ
+
+\  ----------------------------------------------------- CMOVE>
+: T.COMMA.SEQ  ( n -- , lay down N sequential bytes )
+    0 ?DO I C, LOOP
+;
+CREATE T-BLANK-DATA   64 T.COMMA.SEQ
+T{ T-BLANK-DATA 6 + T-BLANK-DATA 7 + 3 CMOVE>
+T{ T-BLANK-DATA 5 + C@ }T{ 5 }T
+T{ T-BLANK-DATA 6 + C@ }T{ 6 }T
+T{ T-BLANK-DATA 7 + C@ }T{ 6 }T
+T{ T-BLANK-DATA 8 + C@ }T{ 7 }T
+T{ T-BLANK-DATA 9 + C@ }T{ 8 }T
+T{ T-BLANK-DATA 10 + C@ }T{ 10 }T
+FORGET T.COMMA.SEQ
+
+\  ----------------------------------------------------- COMPARE
+T{ : T.COMPARE.1 S" abcd" S" abcd"    compare ; t.compare.1 }T{   0 }T
+T{ : T.COMPARE.2 S" abcd" S" abcde"   compare ; t.compare.2 }T{  -1 }T
+T{ : T.COMPARE.3 S" abcdef" S" abcde" compare ; t.compare.3 }T{   1 }T
+T{ : T.COMPARE.4 S" abGd" S" abcde"   compare ; t.compare.4 }T{  -1 }T
+T{ : T.COMPARE.5 S" abcd" S" aXcde"   compare ; t.compare.5 }T{   1 }T
+T{ : T.COMPARE.6 S" abGd" S" abcd"    compare ; t.compare.6 }T{  -1 }T
+T{ : T.COMPARE.7 S" World" S" World"  compare ; t.compare.7 }T{   0 }T
+FORGET T.COMPARE.1
+
+\  ----------------------------------------------------- SEARCH
+: STR-SEARCH S" ABCDefghIJKL" ;
+T{ : T.SEARCH.1 STR-SEARCH S" ABCD" SEARCH ; T.SEARCH.1 }T{ STR-SEARCH TRUE }T
+T{ : T.SEARCH.2 STR-SEARCH S" efg"  SEARCH ; T.SEARCH.2 }T{
+     STR-SEARCH 4 - SWAP 4 CHARS + SWAP TRUE }T
+T{ : T.SEARCH.3 STR-SEARCH S" IJKL" SEARCH ; T.SEARCH.3 }T{
+     STR-SEARCH DROP 8 CHARS + 4 TRUE }T
+T{ : T.SEARCH.4 STR-SEARCH STR-SEARCH SEARCH ; T.SEARCH.4 }T{
+     STR-SEARCH  TRUE }T
+
+T{ : T.SEARCH.5 STR-SEARCH S" CDex" SEARCH ; T.SEARCH.5 }T{
+     STR-SEARCH  FALSE }T
+T{ : T.SEARCH.6 STR-SEARCH S" KLM" SEARCH ; T.SEARCH.6 }T{
+     STR-SEARCH  FALSE }T
+FORGET STR-SEARCH
+
+\  ----------------------------------------------------- SLITERAL
+CREATE FAKE-STRING  CHAR H C,   CHAR e C,  CHAR l C, CHAR l C, CHAR o C,
+ALIGN
+T{ : T.SLITERAL.1  [ FAKE-STRING 5 ] SLITERAL ; T.SLITERAL.1   FAKE-STRING 5 COMPARE
+     }T{ 0 }T
+
+}test

diff --git a/fth/t_tools.fth b/fth/t_tools.fth
index af6f073..72e2c85 100644 (file)
--- a/fth/t_tools.fth
+++ b/fth/t_tools.fth
@@ -1,83 +1,83 @@
-\ @(#) t_tools.fth 97/12/10 1.1\r
-\ Test Tools for pForth\r
-\\r
-\ Based on testing tools from John Hayes\r
-\ (c) 1993 Johns Hopkins University / Applied Physics Laboratory\r
-\\r
-\ Syntax was changed to avoid conflict with { -> and } for local variables.\r
-\ Also added tracking of #successes and #errors.\r
-\r
-anew task-t_tools.fth\r
-\r
-decimal\r
-\r
-variable TEST-DEPTH\r
-variable TEST-PASSED\r
-variable TEST-FAILED\r
-\r
-: TEST{\r
-        depth test-depth !\r
-        0 test-passed !\r
-        0 test-failed !\r
-;\r
-\r
-\r
-: }TEST\r
-        test-passed @ 4 .r ."  passed, "\r
-        test-failed @ 4 .r ."  failed." cr\r
-;\r
-\r
-\r
-VARIABLE actual-depth          \ stack record\r
-CREATE actual-results 20 CELLS ALLOT\r
-\r
-: empty-stack \ ( ... -- ) Empty stack.\r
-   DEPTH dup 0>\r
-   IF 0 DO DROP LOOP\r
-   ELSE drop\r
-   THEN ;\r
-\r
-CREATE the-test 128 CHARS ALLOT\r
-\r
-: ERROR        \ ( c-addr u -- ) Display an error message followed by\r
-               \ the line that had the error.\r
-   TYPE the-test COUNT TYPE CR \ display line corresponding to error\r
-   empty-stack                         \ throw away every thing else\r
-;\r
-\r
-\r
-: T{\r
-       source the-test place\r
-       empty-stack\r
-;\r
-\r
-: }T{  \ ( ... -- ) Record depth and content of stack.\r
-       DEPTH actual-depth !    \ record depth\r
-       DEPTH 0\r
-       ?DO\r
-               actual-results I CELLS + !\r
-       LOOP \ save them\r
-;\r
-\r
-: }T   \ ( ... -- ) Compare stack (expected) contents with saved\r
-               \ (actual) contents.\r
-       DEPTH\r
-       actual-depth @ =\r
-       IF      \ if depths match\r
-               1 test-passed +!  \ assume will pass\r
-               DEPTH 0\r
-               ?DO                     \ for each stack item\r
-                       actual-results I CELLS + @ \ compare actual with expected\r
-                       <>\r
-                       IF\r
-                               -1 test-passed +!\r
-                               1 test-failed +!\r
-                               S" INCORRECT RESULT: " error\r
-                               LEAVE\r
-                       THEN\r
-               LOOP\r
-       ELSE                            \ depth mismatch\r
-               1 test-failed +!\r
-               S" WRONG NUMBER OF RESULTS: " error\r
-       THEN\r
-;\r
+\ @(#) t_tools.fth 97/12/10 1.1
+\ Test Tools for pForth
+\
+\ Based on testing tools from John Hayes
+\ (c) 1993 Johns Hopkins University / Applied Physics Laboratory
+\
+\ Syntax was changed to avoid conflict with { -> and } for local variables.
+\ Also added tracking of #successes and #errors.
+
+anew task-t_tools.fth
+
+decimal
+
+variable TEST-DEPTH
+variable TEST-PASSED
+variable TEST-FAILED
+
+: TEST{
+        depth test-depth !
+        0 test-passed !
+        0 test-failed !
+;
+
+
+: }TEST
+        test-passed @ 4 .r ."  passed, "
+        test-failed @ 4 .r ."  failed." cr
+;
+
+
+VARIABLE actual-depth       \ stack record
+CREATE actual-results 20 CELLS ALLOT
+
+: empty-stack \ ( ... -- ) Empty stack.
+   DEPTH dup 0>
+   IF 0 DO DROP LOOP
+   ELSE drop
+   THEN ;
+
+CREATE the-test 128 CHARS ALLOT
+
+: ERROR     \ ( c-addr u -- ) Display an error message followed by
+        \ the line that had the error.
+   TYPE the-test COUNT TYPE CR \ display line corresponding to error
+   empty-stack          \ throw away every thing else
+;
+
+
+: T{
+    source the-test place
+    empty-stack
+;
+
+: }T{   \ ( ... -- ) Record depth and content of stack.
+    DEPTH actual-depth !    \ record depth
+    DEPTH 0
+    ?DO
+        actual-results I CELLS + !
+    LOOP \ save them
+;
+
+: }T    \ ( ... -- ) Compare stack (expected) contents with saved
+        \ (actual) contents.
+    DEPTH
+    actual-depth @ =
+    IF  \ if depths match
+        1 test-passed +!  \ assume will pass
+        DEPTH 0
+        ?DO             \ for each stack item
+            actual-results I CELLS + @ \ compare actual with expected
+            <>
+            IF
+                -1 test-passed +!
+                1 test-failed +!
+                S" INCORRECT RESULT: " error
+                LEAVE
+            THEN
+        LOOP
+    ELSE                \ depth mismatch
+        1 test-failed +!
+        S" WRONG NUMBER OF RESULTS: " error
+    THEN
+;

diff --git a/fth/termio.fth b/fth/termio.fth
index ef6d19b..ab8cc17 100644 (file)
--- a/fth/termio.fth
+++ b/fth/termio.fth
@@ -1,88 +1,88 @@
-\ Terminal I/O\r
-\\r
-\ Requires an ANSI compatible terminal.\r
-\\r
-\ To get Windows computers to use ANSI mode in their DOS windows,\r
-\ Add this line to "C:\CONFIG.SYS" then reboot.\r
-\  \r
-\  device=c:\windows\command\ansi.sys\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1988 Phil Burk\r
-\ Revised 2001 for pForth\r
-\r
-ANEW TASK-TERMIO.FTH\r
-decimal\r
-\r
-$ 08 constant ASCII_BACKSPACE\r
-$ 7F constant ASCII_DELETE\r
-$ 1B constant ASCII_ESCAPE\r
-$ 01 constant ASCII_CTRL_A\r
-$ 05 constant ASCII_CTRL_E\r
-$ 18 constant ASCII_CTRL_X\r
-\r
-\ ANSI Terminal Control\r
-: ESC[ ( send ESCAPE and [ )\r
-       ASCII_ESCAPE emit\r
-       ascii [ emit\r
-;\r
-\r
-: CLS ( -- , clear screen )\r
-       ESC[ ." 2J"\r
-;\r
-\r
-: TIO.BACKWARDS ( n -- , move cursor backwards )\r
-       ESC[\r
-       base @ >r decimal\r
-       0 .r\r
-       r> base !\r
-       ascii D emit\r
-;\r
-\r
-: TIO.FORWARDS ( n -- , move cursor forwards )\r
-       ESC[\r
-       base @ >r decimal\r
-       0 .r\r
-       r> base !\r
-       ascii C emit\r
-;\r
-\r
-: TIO.ERASE.EOL ( -- , erase to the end of the line )\r
-       ESC[\r
-       ascii K emit\r
-;\r
-\r
-\r
-: BELL ( -- , ring the terminal bell )\r
-       7 emit\r
-;\r
-\r
-: BACKSPACE ( -- , backspace action )\r
-       8 emit  space  8 emit\r
-;\r
-\r
-0 [IF] \ for testing\r
-\r
-: SHOWKEYS  ( -- , show keys pressed in hex )\r
-       BEGIN\r
-               key\r
-               dup .\r
-               ." , $ " dup .hex cr\r
-               ascii q =\r
-       UNTIL\r
-;\r
-\r
-: AZ ascii z 1+ ascii a DO i emit LOOP ;\r
-\r
-: TEST.BACK1\r
-       AZ 5 tio.backwards\r
-       1000 msec\r
-       tio.erase.eol\r
-;\r
-: TEST.BACK2\r
-       AZ 10 tio.backwards\r
-       1000 msec\r
-       ." 12345"\r
-       1000 msec\r
-;\r
-[THEN]\r
+\ Terminal I/O
+\
+\ Requires an ANSI compatible terminal.
+\
+\ To get Windows computers to use ANSI mode in their DOS windows,
+\ Add this line to "C:\CONFIG.SYS" then reboot.
+\
+\  device=c:\windows\command\ansi.sys
+\
+\ Author: Phil Burk
+\ Copyright 1988 Phil Burk
+\ Revised 2001 for pForth
+
+ANEW TASK-TERMIO.FTH
+decimal
+
+$ 08 constant ASCII_BACKSPACE
+$ 7F constant ASCII_DELETE
+$ 1B constant ASCII_ESCAPE
+$ 01 constant ASCII_CTRL_A
+$ 05 constant ASCII_CTRL_E
+$ 18 constant ASCII_CTRL_X
+
+\ ANSI Terminal Control
+: ESC[ ( send ESCAPE and [ )
+    ASCII_ESCAPE emit
+    ascii [ emit
+;
+
+: CLS ( -- , clear screen )
+    ESC[ ." 2J"
+;
+
+: TIO.BACKWARDS ( n -- , move cursor backwards )
+    ESC[
+    base @ >r decimal
+    0 .r
+    r> base !
+    ascii D emit
+;
+
+: TIO.FORWARDS ( n -- , move cursor forwards )
+    ESC[
+    base @ >r decimal
+    0 .r
+    r> base !
+    ascii C emit
+;
+
+: TIO.ERASE.EOL ( -- , erase to the end of the line )
+    ESC[
+    ascii K emit
+;
+
+
+: BELL ( -- , ring the terminal bell )
+    7 emit
+;
+
+: BACKSPACE ( -- , backspace action )
+    8 emit  space  8 emit
+;
+
+0 [IF] \ for testing
+
+: SHOWKEYS  ( -- , show keys pressed in hex )
+    BEGIN
+        key
+        dup .
+        ." , $ " dup .hex cr
+        ascii q =
+    UNTIL
+;
+
+: AZ ascii z 1+ ascii a DO i emit LOOP ;
+
+: TEST.BACK1
+    AZ 5 tio.backwards
+    1000 msec
+    tio.erase.eol
+;
+: TEST.BACK2
+    AZ 10 tio.backwards
+    1000 msec
+    ." 12345"
+    1000 msec
+;
+[THEN]

diff --git a/fth/tester.fth b/fth/tester.fth
index 91b1294..9ad2fc9 100644 (file)
--- a/fth/tester.fth
+++ b/fth/tester.fth
@@ -1,54 +1,54 @@
-\ From: John Hayes S1I\r
-\ Subject: tester.fr\r
-\ Date: Mon, 27 Nov 95 13:10:09 PST  \r
-\r
-\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY\r
-\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.\r
-\ VERSION 1.1\r
-HEX\r
-\r
-\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY\r
-\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.\r
-VARIABLE VERBOSE\r
-   FALSE VERBOSE !\r
-\r
-: EMPTY-STACK  \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.\r
-   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;\r
-\r
-: ERROR                \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY\r
-               \ THE LINE THAT HAD THE ERROR.\r
-   TYPE SOURCE TYPE CR                 \ DISPLAY LINE CORRESPONDING TO ERROR\r
-   EMPTY-STACK                         \ THROW AWAY EVERY THING ELSE\r
-;\r
-\r
-VARIABLE ACTUAL-DEPTH                  \ STACK RECORD\r
-CREATE ACTUAL-RESULTS 20 CELLS ALLOT\r
-\r
-: {            \ ( -- ) SYNTACTIC SUGAR.\r
-   ;\r
-\r
-: ->           \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.\r
-   DEPTH DUP ACTUAL-DEPTH !            \ RECORD DEPTH\r
-   ?DUP IF                             \ IF THERE IS SOMETHING ON STACK\r
-      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM\r
-   THEN ;\r
-\r
-: }            \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED\r
-               \ (ACTUAL) CONTENTS.\r
-   DEPTH ACTUAL-DEPTH @ = IF           \ IF DEPTHS MATCH\r
-      DEPTH ?DUP IF                    \ IF THERE IS SOMETHING ON THE STACK\r
-         0 DO                          \ FOR EACH STACK ITEM\r
-           ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED\r
-           <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN\r
-        LOOP\r
-      THEN\r
-   ELSE                                        \ DEPTH MISMATCH\r
-      S" WRONG NUMBER OF RESULTS: " ERROR\r
-   THEN ;\r
-\r
-: TESTING      \ ( -- ) TALKING COMMENT.\r
-   SOURCE VERBOSE @\r
-   IF DUP >R TYPE CR R> >IN !\r
-   ELSE >IN ! DROP\r
-   THEN ;\r
-\r
+\ From: John Hayes S1I
+\ Subject: tester.fr
+\ Date: Mon, 27 Nov 95 13:10:09 PST
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.1
+HEX
+
+\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
+\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
+VARIABLE VERBOSE
+   FALSE VERBOSE !
+
+: EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
+   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
+
+: ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
+        \ THE LINE THAT HAD THE ERROR.
+   TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
+   EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
+;
+
+VARIABLE ACTUAL-DEPTH           \ STACK RECORD
+CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+
+: {     \ ( -- ) SYNTACTIC SUGAR.
+   ;
+
+: ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
+   DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
+   ?DUP IF              \ IF THERE IS SOMETHING ON STACK
+      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
+   THEN ;
+
+: }     \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
+        \ (ACTUAL) CONTENTS.
+   DEPTH ACTUAL-DEPTH @ = IF        \ IF DEPTHS MATCH
+      DEPTH ?DUP IF         \ IF THERE IS SOMETHING ON THE STACK
+         0 DO               \ FOR EACH STACK ITEM
+        ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
+        <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
+     LOOP
+      THEN
+   ELSE                 \ DEPTH MISMATCH
+      S" WRONG NUMBER OF RESULTS: " ERROR
+   THEN ;
+
+: TESTING   \ ( -- ) TALKING COMMENT.
+   SOURCE VERBOSE @
+   IF DUP >R TYPE CR R> >IN !
+   ELSE >IN ! DROP
+   THEN ;
+

diff --git a/fth/trace.fth b/fth/trace.fth
index 26078d0..c311bc4 100644 (file)
--- a/fth/trace.fth
+++ b/fth/trace.fth
@@ -1,460 +1,460 @@
-\ @(#) trace.fth 98/01/28 1.2\r
-\ TRACE ( <name> -- , trace pForth word )\r
-\\r
-\ Single step debugger.\r
-\   TRACE  ( i*x <name> -- , setup trace for Forth word )\r
-\   S      ( -- , step over )\r
-\   SM     ( many -- , step over many times )\r
-\   SD     ( -- , step down )\r
-\   G      ( -- , go to end of word )\r
-\   GD     ( n -- , go down N levels from current level, stop at end of this level )\r
-\\r
-\ This debugger works by emulating the inner interpreter of pForth.\r
-\ It executes code and maintains a separate return stack for the\r
-\ program under test.  Thus all primitives that operate on the return\r
-\ stack, such as DO and R> must be trapped.  Local variables must\r
-\ also be handled specially.  Several state variables are also\r
-\ saved and restored to establish the context for the program being\r
-\ tested.\r
-\    \r
-\ Copyright 1997 Phil Burk\r
-\\r
-\ Modifications:\r
-\      19990930 John Providenza - Fixed stack bugs in GD\r
-\r
-anew task-trace.fth\r
-\r
-: SPACE.TO.COLUMN  ( col -- )\r
-       out @ - spaces\r
-;\r
-\r
-: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )\r
-       ['] first_colon <\r
-;\r
-\r
-0 value TRACE_IP         \ instruction pointer\r
-0 value TRACE_LEVEL      \ level of descent for inner interpreter\r
-0 value TRACE_LEVEL_MAX  \ maximum level of descent\r
-\r
-private{\r
-\r
-\ use fake return stack\r
-128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes\r
-create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot\r
-variable TRACE-RSP\r
-: TRACE.>R     ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ;  \ *(--rsp) = n\r
-: TRACE.R>     ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ;  \ n = *rsp++\r
-: TRACE.R@     ( -- n ) trace-rsp @ @ ; ; \ n = *rsp\r
-: TRACE.RPICK  ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]\r
-: TRACE.0RP    ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;\r
-: TRACE.RDROP  ( --  ) cell trace-rsp +! ;\r
-: TRACE.RCHECK ( -- , abort if return stack out of range )\r
-       trace-rsp @ trace-return-stack u<\r
-               abort" TRACE return stack OVERFLOW!"\r
-       trace-rsp @ trace-return-stack trace_return_size + 12 + u>\r
-               abort" TRACE return stack UNDERFLOW!"\r
-;\r
-\r
-\ save and restore several state variables\r
-10 cells constant TRACE_STATE_SIZE\r
-create TRACE-STATE-1 TRACE_STATE_SIZE allot\r
-create TRACE-STATE-2 TRACE_STATE_SIZE allot\r
-\r
-variable TRACE-STATE-PTR\r
-: TRACE.SAVE++ ( addr -- , save next thing )\r
-       @ trace-state-ptr @ !\r
-       cell trace-state-ptr +!\r
-;\r
-\r
-: TRACE.SAVE.STATE  ( -- )\r
-       state trace.save++\r
-       hld   trace.save++\r
-       base  trace.save++\r
-;\r
-\r
-: TRACE.SAVE.STATE1  ( -- , save normal state )\r
-       trace-state-1 trace-state-ptr !\r
-       trace.save.state\r
-;\r
-: TRACE.SAVE.STATE2  ( -- , save state of word being debugged )\r
-       trace-state-2 trace-state-ptr !\r
-       trace.save.state\r
-;\r
-\r
-\r
-: TRACE.RESTORE++ ( addr -- , restore next thing )\r
-       trace-state-ptr @ @ swap !\r
-       cell trace-state-ptr +!\r
-;\r
-\r
-: TRACE.RESTORE.STATE  ( -- )\r
-       state trace.restore++\r
-       hld   trace.restore++\r
-       base  trace.restore++\r
-;\r
-\r
-: TRACE.RESTORE.STATE1  ( -- )\r
-       trace-state-1 trace-state-ptr !\r
-       trace.restore.state\r
-;\r
-: TRACE.RESTORE.STATE2  ( -- )\r
-       trace-state-2 trace-state-ptr !\r
-       trace.restore.state\r
-;\r
-\r
-\ The implementation of these pForth primitives is specific to pForth.\r
-\r
-variable TRACE-LOCALS-PTR  \ point to top of local frame\r
-\r
-\ create a return stack frame for NUM local variables\r
-: TRACE.(LOCAL.ENTRY)  ( x0 x1 ... xn n -- )  { num | lp -- }\r
-       trace-locals-ptr @ trace.>r\r
-       trace-rsp @ trace-locals-ptr !\r
-       trace-rsp @  num cells - trace-rsp !  \ make room for locals\r
-       trace-rsp @ -> lp\r
-       num 0\r
-       DO\r
-               lp !\r
-               cell +-> lp  \ move data into locals frame on return stack\r
-       LOOP\r
-;\r
-       \r
-: TRACE.(LOCAL.EXIT) ( -- )\r
-       trace-locals-ptr @  trace-rsp !\r
-       trace.r> trace-locals-ptr !\r
-;\r
-: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )\r
-       trace-locals-ptr @  swap cells - @\r
-;\r
-: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;\r
-: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;\r
-: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;\r
-: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;\r
-: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;\r
-: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;\r
-: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;\r
-: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;\r
-\r
-: TRACE.(LOCAL!) ( n l# -- , store into local frame )\r
-       trace-locals-ptr @  swap cells - !\r
-;\r
-: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;\r
-: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;\r
-: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;\r
-: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;\r
-: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;\r
-: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;\r
-: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;\r
-: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;\r
-\r
-: TRACE.(LOCAL+!) ( n l# -- , store into local frame )\r
-       trace-locals-ptr @  swap cells - +!\r
-;\r
-: TRACE.(?DO)  { limit start ip -- ip' }\r
-       limit start =\r
-       IF\r
-               ip @ +-> ip \ BRANCH\r
-       ELSE\r
-               start trace.>r\r
-               limit trace.>r\r
-               cell +-> ip\r
-       THEN\r
-       ip\r
-;\r
-\r
-: TRACE.(LOOP)  { ip | limit indx -- ip' }\r
-       trace.r> -> limit\r
-       trace.r> 1+ -> indx\r
-       limit indx =\r
-       IF\r
-               cell +-> ip\r
-       ELSE\r
-               indx trace.>r\r
-               limit trace.>r\r
-               ip @ +-> ip\r
-       THEN\r
-       ip\r
-;\r
-\r
-: TRACE.(+LOOP)  { delta ip | limit indx oldindx -- ip' }\r
-       trace.r> -> limit\r
-       trace.r> -> oldindx\r
-       oldindx delta + -> indx\r
-\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
-\  if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
-\    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
-       oldindx limit -    limit 1-    indx -  AND $ 80000000 AND\r
-          indx limit -    limit 1- oldindx -  AND $ 80000000 AND OR\r
-       IF\r
-               cell +-> ip\r
-       ELSE\r
-               indx trace.>r\r
-               limit trace.>r\r
-               ip @ +-> ip\r
-       THEN\r
-       ip\r
-;\r
-\r
-: TRACE.CHECK.IP  {  ip -- }\r
-       ip ['] first_colon u<\r
-       ip here u> OR\r
-       IF\r
-               ." TRACE - IP out of range = " ip .hex cr\r
-               abort\r
-       THEN\r
-;\r
-\r
-: TRACE.SHOW.IP { ip -- , print name and offset }\r
-       ip code> >name dup id.\r
-       name> >code ip swap - ."  +" .\r
-;\r
-\r
-: TRACE.SHOW.STACK { | mdepth -- }\r
-       base @ >r\r
-       ." <" base @ decimal 1 .r ." :"\r
-       depth 1 .r ." > "\r
-       r> base !\r
-       depth 5 min -> mdepth\r
-       depth mdepth  -\r
-       IF\r
-               ." ... "  \ if we don't show entire stack\r
-       THEN\r
-       mdepth 0\r
-       ?DO\r
-               mdepth i 1+ - pick .  \ show numbers in current base\r
-       LOOP\r
-;\r
-\r
-: TRACE.SHOW.NEXT { ip -- }\r
-       >newline\r
-       ip trace.check.ip\r
-\ show word name and offset\r
-       ." << "\r
-       ip trace.show.ip\r
-       16 space.to.column\r
-\ show data stack\r
-       trace.show.stack\r
-       40 space.to.column ."  ||"\r
-       trace_level 2* spaces\r
-       ip code@\r
-       cell +-> ip\r
-\ show primitive about to be executed\r
-       dup .xt space\r
-\ trap any primitives that are followed by inline data\r
-       CASE\r
-               ['] (LITERAL)  OF ip @  . ENDOF\r
-               ['] (ALITERAL) OF ip a@ . ENDOF\r
-[ exists? (FLITERAL) [IF] ]\r
-               ['] (FLITERAL) OF ip f@ f. ENDOF\r
-[ [THEN] ]\r
-               ['] BRANCH     OF ip @  . ENDOF\r
-               ['] 0BRANCH    OF ip @  . ENDOF\r
-               ['] (.")       OF ip count type .' "' ENDOF\r
-               ['] (C")       OF ip count type .' "' ENDOF\r
-               ['] (S")       OF ip count type .' "' ENDOF\r
-       ENDCASE\r
-       65 space.to.column ." >> "\r
-;\r
-\r
-: TRACE.DO.PRIMITIVE  { ip xt | oldhere --  ip' , perform code at ip }\r
-       xt\r
-       CASE\r
-               0 OF -1 +-> trace_level  trace.r> -> ip ENDOF \ EXIT\r
-               ['] (CREATE)   OF ip cell- body_offset + ENDOF\r
-               ['] (LITERAL)  OF ip @ cell +-> ip ENDOF\r
-               ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF\r
-[ exists? (FLITERAL) [IF] ]\r
-               ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF\r
-[ [THEN] ]\r
-               ['] BRANCH     OF ip @ +-> ip ENDOF\r
-               ['] 0BRANCH    OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF\r
-               ['] >R         OF trace.>r ENDOF\r
-               ['] R>         OF trace.r> ENDOF\r
-               ['] R@         OF trace.r@ ENDOF\r
-               ['] RDROP      OF trace.rdrop ENDOF\r
-               ['] 2>R        OF trace.>r trace.>r ENDOF\r
-               ['] 2R>        OF trace.r> trace.r> ENDOF\r
-               ['] 2R@        OF trace.r@ 1 trace.rpick ENDOF\r
-               ['] i          OF 1 trace.rpick ENDOF\r
-               ['] j          OF 3 trace.rpick ENDOF\r
-               ['] (LEAVE)    OF trace.rdrop trace.rdrop  ip @ +-> ip ENDOF\r
-               ['] (LOOP)     OF ip trace.(loop) -> ip  ENDOF\r
-               ['] (+LOOP)    OF ip trace.(+loop) -> ip  ENDOF\r
-               ['] (DO)       OF trace.>r trace.>r ENDOF\r
-               ['] (?DO)      OF ip trace.(?do) -> ip ENDOF\r
-               ['] (.")       OF ip count type  ip count + aligned -> ip ENDOF\r
-               ['] (C")       OF ip  ip count + aligned -> ip ENDOF\r
-               ['] (S")       OF ip count  ip count + aligned -> ip ENDOF\r
-               ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF\r
-               ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF\r
-               ['] (LOCAL@)   OF trace.(local@)   ENDOF\r
-               ['] (1_LOCAL@) OF trace.(1_local@) ENDOF\r
-               ['] (2_LOCAL@) OF trace.(2_local@) ENDOF\r
-               ['] (3_LOCAL@) OF trace.(3_local@) ENDOF\r
-               ['] (4_LOCAL@) OF trace.(4_local@) ENDOF\r
-               ['] (5_LOCAL@) OF trace.(5_local@) ENDOF\r
-               ['] (6_LOCAL@) OF trace.(6_local@) ENDOF\r
-               ['] (7_LOCAL@) OF trace.(7_local@) ENDOF\r
-               ['] (8_LOCAL@) OF trace.(8_local@) ENDOF\r
-               ['] (LOCAL!)   OF trace.(local!)   ENDOF\r
-               ['] (1_LOCAL!) OF trace.(1_local!) ENDOF\r
-               ['] (2_LOCAL!) OF trace.(2_local!) ENDOF\r
-               ['] (3_LOCAL!) OF trace.(3_local!) ENDOF\r
-               ['] (4_LOCAL!) OF trace.(4_local!) ENDOF\r
-               ['] (5_LOCAL!) OF trace.(5_local!) ENDOF\r
-               ['] (6_LOCAL!) OF trace.(6_local!) ENDOF\r
-               ['] (7_LOCAL!) OF trace.(7_local!) ENDOF\r
-               ['] (8_LOCAL!) OF trace.(8_local!) ENDOF\r
-               ['] (LOCAL+!)  OF trace.(local+!)  ENDOF\r
-               >r xt EXECUTE r>\r
-       ENDCASE\r
-       ip\r
-;\r
-\r
-: TRACE.DO.NEXT  { ip | xt oldhere --  ip' , perform code at ip }\r
-       ip trace.check.ip\r
-\ set context for word under test\r
-       trace.save.state1\r
-       here -> oldhere\r
-       trace.restore.state2\r
-       oldhere 256 + dp !\r
-\ get execution token\r
-       ip code@ -> xt\r
-       cell +-> ip\r
-\ execute token\r
-       xt is.primitive?\r
-       IF  \ primitive\r
-               ip xt trace.do.primitive -> ip\r
-       ELSE \ secondary\r
-               trace_level trace_level_max <\r
-               IF\r
-                       ip trace.>r         \ threaded execution\r
-                       1 +-> trace_level\r
-                       xt codebase + -> ip\r
-               ELSE\r
-                       \ treat it as a primitive\r
-                       ip xt trace.do.primitive -> ip\r
-               THEN            \r
-       THEN\r
-\ restore original context\r
-       trace.rcheck\r
-       trace.save.state2\r
-       trace.restore.state1\r
-       oldhere dp !\r
-       ip\r
-;\r
-\r
-: TRACE.NEXT { ip | xt -- ip' }\r
-       trace_level 0>\r
-       IF\r
-               ip trace.do.next -> ip\r
-       THEN\r
-       trace_level 0>\r
-       IF\r
-               ip trace.show.next\r
-       ELSE\r
-               trace-stack on\r
-               ." Finished." cr\r
-       THEN\r
-       ip\r
-;\r
-\r
-}private\r
-\r
-: TRACE ( i*x <name> -- i*x , setup trace environment )\r
-       ' dup is.primitive?\r
-       IF\r
-               drop ." Sorry. You can't trace a primitive." cr\r
-       ELSE\r
-               1 -> trace_level\r
-               trace_level -> trace_level_max\r
-               trace.0rp\r
-               >code -> trace_ip\r
-               trace_ip trace.show.next\r
-               trace-stack off\r
-               trace.save.state2\r
-       THEN\r
-;\r
-\r
-: s ( -- , step over )\r
-       trace_level -> trace_level_max\r
-       trace_ip trace.next -> trace_ip\r
-;\r
-\r
-: sd ( -- , step down )\r
-       trace_level 1+ -> trace_level_max\r
-       trace_ip trace.next -> trace_ip\r
-;\r
-\r
-: sm ( many -- , step many times )\r
-       trace_level -> trace_level_max\r
-       0\r
-       ?DO\r
-               trace_ip trace.next -> trace_ip\r
-       LOOP\r
-;\r
-\r
-defer trace.user   ( IP -- stop?  )\r
-' 0= is trace.user\r
-\r
-: gd { more_levels | stop_level -- }\r
-       here   what's trace.user   u<  \ has it been forgotten?\r
-       IF\r
-               ." Resetting TRACE.USER !!!" cr\r
-               ['] 0= is trace.user\r
-       THEN\r
-\r
-       more_levels 0<\r
-       more_levels 10 >\r
-       or      \ 19990930 - OR was missing\r
-       IF\r
-               ." GD level out of range (0-10), = " more_levels . cr\r
-       ELSE\r
-               trace_level more_levels + -> trace_level_max\r
-               trace_level 1- -> stop_level\r
-               BEGIN\r
-                       trace_ip trace.user \ call deferred user word\r
-                       ?dup \ leave flag for UNTIL \ 19990930 - was DUP\r
-                       IF\r
-                               ." TRACE.USER returned " dup . ." so stopping execution." cr\r
-                       ELSE\r
-                               trace_ip trace.next -> trace_ip\r
-                               trace_level stop_level > not\r
-                       THEN\r
-               UNTIL\r
-       THEN\r
-;\r
-\r
-: g ( -- , execute until end of word )\r
-       0 gd\r
-;\r
-\r
-: TRACE.HELP ( -- )\r
-       ."   TRACE  ( i*x <name> -- , setup trace for Forth word )" cr\r
-       ."   S      ( -- , step over )" cr\r
-       ."   SM     ( many -- , step over many times )" cr\r
-       ."   SD     ( -- , step down )" cr\r
-       ."   G      ( -- , go to end of word )" cr\r
-       ."   GD     ( n -- , go down N levels from current level," cr\r
-       ."                   stop at end of this level )" cr\r
-;\r
-\r
-privatize\r
-\r
-0 [IF]\r
-variable var1\r
-100 var1 !\r
-: FOO  dup IF 1 + . THEN 77 var1 @ + . ;\r
-: ZOO 29 foo 99 22 + . ;\r
-: ROO 92 >r 1 r@ + . r> . ;\r
-: MOO  c" hello" count type\r
-       ." This is a message." cr\r
-       s" another message" type cr\r
-;\r
-: KOO 7 FOO ." DONE" ;\r
-: TR.DO  4 0 DO i . LOOP ;\r
-: TR.?DO  0 ?DO i . LOOP ;\r
-: TR.LOC1 { aa bb } aa bb + . ;\r
-: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;\r
-       \r
-[THEN]\r
+\ @(#) trace.fth 98/01/28 1.2
+\ TRACE ( <name> -- , trace pForth word )
+\
+\ Single step debugger.
+\   TRACE  ( i*x <name> -- , setup trace for Forth word )
+\   S      ( -- , step over )
+\   SM     ( many -- , step over many times )
+\   SD     ( -- , step down )
+\   G      ( -- , go to end of word )
+\   GD     ( n -- , go down N levels from current level, stop at end of this level )
+\
+\ This debugger works by emulating the inner interpreter of pForth.
+\ It executes code and maintains a separate return stack for the
+\ program under test.  Thus all primitives that operate on the return
+\ stack, such as DO and R> must be trapped.  Local variables must
+\ also be handled specially.  Several state variables are also
+\ saved and restored to establish the context for the program being
+\ tested.
+\
+\ Copyright 1997 Phil Burk
+\
+\ Modifications:
+\      19990930 John Providenza - Fixed stack bugs in GD
+
+anew task-trace.fth
+
+: SPACE.TO.COLUMN  ( col -- )
+    out @ - spaces
+;
+
+: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
+    ['] first_colon <
+;
+
+0 value TRACE_IP         \ instruction pointer
+0 value TRACE_LEVEL      \ level of descent for inner interpreter
+0 value TRACE_LEVEL_MAX  \ maximum level of descent
+
+private{
+
+\ use fake return stack
+128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
+create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
+variable TRACE-RSP
+: TRACE.>R     ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ;  \ *(--rsp) = n
+: TRACE.R>     ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ;  \ n = *rsp++
+: TRACE.R@     ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
+: TRACE.RPICK  ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
+: TRACE.0RP    ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
+: TRACE.RDROP  ( --  ) cell trace-rsp +! ;
+: TRACE.RCHECK ( -- , abort if return stack out of range )
+    trace-rsp @ trace-return-stack u<
+        abort" TRACE return stack OVERFLOW!"
+    trace-rsp @ trace-return-stack trace_return_size + 12 + u>
+        abort" TRACE return stack UNDERFLOW!"
+;
+
+\ save and restore several state variables
+10 cells constant TRACE_STATE_SIZE
+create TRACE-STATE-1 TRACE_STATE_SIZE allot
+create TRACE-STATE-2 TRACE_STATE_SIZE allot
+
+variable TRACE-STATE-PTR
+: TRACE.SAVE++ ( addr -- , save next thing )
+    @ trace-state-ptr @ !
+    cell trace-state-ptr +!
+;
+
+: TRACE.SAVE.STATE  ( -- )
+    state trace.save++
+    hld   trace.save++
+    base  trace.save++
+;
+
+: TRACE.SAVE.STATE1  ( -- , save normal state )
+    trace-state-1 trace-state-ptr !
+    trace.save.state
+;
+: TRACE.SAVE.STATE2  ( -- , save state of word being debugged )
+    trace-state-2 trace-state-ptr !
+    trace.save.state
+;
+
+
+: TRACE.RESTORE++ ( addr -- , restore next thing )
+    trace-state-ptr @ @ swap !
+    cell trace-state-ptr +!
+;
+
+: TRACE.RESTORE.STATE  ( -- )
+    state trace.restore++
+    hld   trace.restore++
+    base  trace.restore++
+;
+
+: TRACE.RESTORE.STATE1  ( -- )
+    trace-state-1 trace-state-ptr !
+    trace.restore.state
+;
+: TRACE.RESTORE.STATE2  ( -- )
+    trace-state-2 trace-state-ptr !
+    trace.restore.state
+;
+
+\ The implementation of these pForth primitives is specific to pForth.
+
+variable TRACE-LOCALS-PTR  \ point to top of local frame
+
+\ create a return stack frame for NUM local variables
+: TRACE.(LOCAL.ENTRY)  ( x0 x1 ... xn n -- )  { num | lp -- }
+    trace-locals-ptr @ trace.>r
+    trace-rsp @ trace-locals-ptr !
+    trace-rsp @  num cells - trace-rsp !  \ make room for locals
+    trace-rsp @ -> lp
+    num 0
+    DO
+        lp !
+        cell +-> lp  \ move data into locals frame on return stack
+    LOOP
+;
+
+: TRACE.(LOCAL.EXIT) ( -- )
+    trace-locals-ptr @  trace-rsp !
+    trace.r> trace-locals-ptr !
+;
+: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
+    trace-locals-ptr @  swap cells - @
+;
+: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
+: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
+: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
+: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
+: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
+: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
+: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
+: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
+
+: TRACE.(LOCAL!) ( n l# -- , store into local frame )
+    trace-locals-ptr @  swap cells - !
+;
+: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
+: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
+: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
+: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
+: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
+: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
+: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
+: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
+
+: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
+    trace-locals-ptr @  swap cells - +!
+;
+: TRACE.(?DO)  { limit start ip -- ip' }
+    limit start =
+    IF
+        ip @ +-> ip \ BRANCH
+    ELSE
+        start trace.>r
+        limit trace.>r
+        cell +-> ip
+    THEN
+    ip
+;
+
+: TRACE.(LOOP)  { ip | limit indx -- ip' }
+    trace.r> -> limit
+    trace.r> 1+ -> indx
+    limit indx =
+    IF
+        cell +-> ip
+    ELSE
+        indx trace.>r
+        limit trace.>r
+        ip @ +-> ip
+    THEN
+    ip
+;
+
+: TRACE.(+LOOP)  { delta ip | limit indx oldindx -- ip' }
+    trace.r> -> limit
+    trace.r> -> oldindx
+    oldindx delta + -> indx
+\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
+\  if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
+\    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
+    oldindx limit -    limit 1-    indx -  AND $ 80000000 AND
+       indx limit -    limit 1- oldindx -  AND $ 80000000 AND OR
+    IF
+        cell +-> ip
+    ELSE
+        indx trace.>r
+        limit trace.>r
+        ip @ +-> ip
+    THEN
+    ip
+;
+
+: TRACE.CHECK.IP  {  ip -- }
+    ip ['] first_colon u<
+    ip here u> OR
+    IF
+        ." TRACE - IP out of range = " ip .hex cr
+        abort
+    THEN
+;
+
+: TRACE.SHOW.IP { ip -- , print name and offset }
+    ip code> >name dup id.
+    name> >code ip swap - ."  +" .
+;
+
+: TRACE.SHOW.STACK { | mdepth -- }
+    base @ >r
+    ." <" base @ decimal 1 .r ." :"
+    depth 1 .r ." > "
+    r> base !
+    depth 5 min -> mdepth
+    depth mdepth  -
+    IF
+        ." ... "  \ if we don't show entire stack
+    THEN
+    mdepth 0
+    ?DO
+        mdepth i 1+ - pick .  \ show numbers in current base
+    LOOP
+;
+
+: TRACE.SHOW.NEXT { ip -- }
+    >newline
+    ip trace.check.ip
+\ show word name and offset
+    ." << "
+    ip trace.show.ip
+    16 space.to.column
+\ show data stack
+    trace.show.stack
+    40 space.to.column ."  ||"
+    trace_level 2* spaces
+    ip code@
+    cell +-> ip
+\ show primitive about to be executed
+    dup .xt space
+\ trap any primitives that are followed by inline data
+    CASE
+        ['] (LITERAL)  OF ip @  . ENDOF
+        ['] (ALITERAL) OF ip a@ . ENDOF
+[ exists? (FLITERAL) [IF] ]
+        ['] (FLITERAL) OF ip f@ f. ENDOF
+[ [THEN] ]
+        ['] BRANCH     OF ip @  . ENDOF
+        ['] 0BRANCH    OF ip @  . ENDOF
+        ['] (.")       OF ip count type .' "' ENDOF
+        ['] (C")       OF ip count type .' "' ENDOF
+        ['] (S")       OF ip count type .' "' ENDOF
+    ENDCASE
+    65 space.to.column ." >> "
+;
+
+: TRACE.DO.PRIMITIVE  { ip xt | oldhere --  ip' , perform code at ip }
+    xt
+    CASE
+        0 OF -1 +-> trace_level  trace.r> -> ip ENDOF \ EXIT
+        ['] (CREATE)   OF ip cell- body_offset + ENDOF
+        ['] (LITERAL)  OF ip @ cell +-> ip ENDOF
+        ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
+[ exists? (FLITERAL) [IF] ]
+        ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
+[ [THEN] ]
+        ['] BRANCH     OF ip @ +-> ip ENDOF
+        ['] 0BRANCH    OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
+        ['] >R         OF trace.>r ENDOF
+        ['] R>         OF trace.r> ENDOF
+        ['] R@         OF trace.r@ ENDOF
+        ['] RDROP      OF trace.rdrop ENDOF
+        ['] 2>R        OF trace.>r trace.>r ENDOF
+        ['] 2R>        OF trace.r> trace.r> ENDOF
+        ['] 2R@        OF trace.r@ 1 trace.rpick ENDOF
+        ['] i          OF 1 trace.rpick ENDOF
+        ['] j          OF 3 trace.rpick ENDOF
+        ['] (LEAVE)    OF trace.rdrop trace.rdrop  ip @ +-> ip ENDOF
+        ['] (LOOP)     OF ip trace.(loop) -> ip  ENDOF
+        ['] (+LOOP)    OF ip trace.(+loop) -> ip  ENDOF
+        ['] (DO)       OF trace.>r trace.>r ENDOF
+        ['] (?DO)      OF ip trace.(?do) -> ip ENDOF
+        ['] (.")       OF ip count type  ip count + aligned -> ip ENDOF
+        ['] (C")       OF ip  ip count + aligned -> ip ENDOF
+        ['] (S")       OF ip count  ip count + aligned -> ip ENDOF
+        ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
+        ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
+        ['] (LOCAL@)   OF trace.(local@)   ENDOF
+        ['] (1_LOCAL@) OF trace.(1_local@) ENDOF
+        ['] (2_LOCAL@) OF trace.(2_local@) ENDOF
+        ['] (3_LOCAL@) OF trace.(3_local@) ENDOF
+        ['] (4_LOCAL@) OF trace.(4_local@) ENDOF
+        ['] (5_LOCAL@) OF trace.(5_local@) ENDOF
+        ['] (6_LOCAL@) OF trace.(6_local@) ENDOF
+        ['] (7_LOCAL@) OF trace.(7_local@) ENDOF
+        ['] (8_LOCAL@) OF trace.(8_local@) ENDOF
+        ['] (LOCAL!)   OF trace.(local!)   ENDOF
+        ['] (1_LOCAL!) OF trace.(1_local!) ENDOF
+        ['] (2_LOCAL!) OF trace.(2_local!) ENDOF
+        ['] (3_LOCAL!) OF trace.(3_local!) ENDOF
+        ['] (4_LOCAL!) OF trace.(4_local!) ENDOF
+        ['] (5_LOCAL!) OF trace.(5_local!) ENDOF
+        ['] (6_LOCAL!) OF trace.(6_local!) ENDOF
+        ['] (7_LOCAL!) OF trace.(7_local!) ENDOF
+        ['] (8_LOCAL!) OF trace.(8_local!) ENDOF
+        ['] (LOCAL+!)  OF trace.(local+!)  ENDOF
+        >r xt EXECUTE r>
+    ENDCASE
+    ip
+;
+
+: TRACE.DO.NEXT  { ip | xt oldhere --  ip' , perform code at ip }
+    ip trace.check.ip
+\ set context for word under test
+    trace.save.state1
+    here -> oldhere
+    trace.restore.state2
+    oldhere 256 + dp !
+\ get execution token
+    ip code@ -> xt
+    cell +-> ip
+\ execute token
+    xt is.primitive?
+    IF  \ primitive
+        ip xt trace.do.primitive -> ip
+    ELSE \ secondary
+        trace_level trace_level_max <
+        IF
+            ip trace.>r         \ threaded execution
+            1 +-> trace_level
+            xt codebase + -> ip
+        ELSE
+            \ treat it as a primitive
+            ip xt trace.do.primitive -> ip
+        THEN
+    THEN
+\ restore original context
+    trace.rcheck
+    trace.save.state2
+    trace.restore.state1
+    oldhere dp !
+    ip
+;
+
+: TRACE.NEXT { ip | xt -- ip' }
+    trace_level 0>
+    IF
+        ip trace.do.next -> ip
+    THEN
+    trace_level 0>
+    IF
+        ip trace.show.next
+    ELSE
+        trace-stack on
+        ." Finished." cr
+    THEN
+    ip
+;
+
+}private
+
+: TRACE ( i*x <name> -- i*x , setup trace environment )
+    ' dup is.primitive?
+    IF
+        drop ." Sorry. You can't trace a primitive." cr
+    ELSE
+        1 -> trace_level
+        trace_level -> trace_level_max
+        trace.0rp
+        >code -> trace_ip
+        trace_ip trace.show.next
+        trace-stack off
+        trace.save.state2
+    THEN
+;
+
+: s ( -- , step over )
+    trace_level -> trace_level_max
+    trace_ip trace.next -> trace_ip
+;
+
+: sd ( -- , step down )
+    trace_level 1+ -> trace_level_max
+    trace_ip trace.next -> trace_ip
+;
+
+: sm ( many -- , step many times )
+    trace_level -> trace_level_max
+    0
+    ?DO
+        trace_ip trace.next -> trace_ip
+    LOOP
+;
+
+defer trace.user   ( IP -- stop?  )
+' 0= is trace.user
+
+: gd { more_levels | stop_level -- }
+    here   what's trace.user   u<  \ has it been forgotten?
+    IF
+        ." Resetting TRACE.USER !!!" cr
+        ['] 0= is trace.user
+    THEN
+
+    more_levels 0<
+    more_levels 10 >
+    or  \ 19990930 - OR was missing
+    IF
+        ." GD level out of range (0-10), = " more_levels . cr
+    ELSE
+        trace_level more_levels + -> trace_level_max
+        trace_level 1- -> stop_level
+        BEGIN
+            trace_ip trace.user \ call deferred user word
+            ?dup \ leave flag for UNTIL \ 19990930 - was DUP
+            IF
+                ." TRACE.USER returned " dup . ." so stopping execution." cr
+            ELSE
+                trace_ip trace.next -> trace_ip
+                trace_level stop_level > not
+            THEN
+        UNTIL
+    THEN
+;
+
+: g ( -- , execute until end of word )
+    0 gd
+;
+
+: TRACE.HELP ( -- )
+    ."   TRACE  ( i*x <name> -- , setup trace for Forth word )" cr
+    ."   S      ( -- , step over )" cr
+    ."   SM     ( many -- , step over many times )" cr
+    ."   SD     ( -- , step down )" cr
+    ."   G      ( -- , go to end of word )" cr
+    ."   GD     ( n -- , go down N levels from current level," cr
+    ."                   stop at end of this level )" cr
+;
+
+privatize
+
+0 [IF]
+variable var1
+100 var1 !
+: FOO  dup IF 1 + . THEN 77 var1 @ + . ;
+: ZOO 29 foo 99 22 + . ;
+: ROO 92 >r 1 r@ + . r> . ;
+: MOO  c" hello" count type
+    ." This is a message." cr
+    s" another message" type cr
+;
+: KOO 7 FOO ." DONE" ;
+: TR.DO  4 0 DO i . LOOP ;
+: TR.?DO  0 ?DO i . LOOP ;
+: TR.LOC1 { aa bb } aa bb + . ;
+: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
+
+[THEN]

diff --git a/fth/tut.fth b/fth/tut.fth
index ea60f18..c52eafa 100644 (file)
--- a/fth/tut.fth
+++ b/fth/tut.fth
@@ -1,70 +1,70 @@
-anew task-tut.fth\r
-\r
-: SUM.OF.N.A ( N -- SUM[N] , calculate sum of N integers )\r
-           0  \ starting value of SUM\r
-           BEGIN\r
-               OVER 0>   \ Is N greater than zero?\r
-           WHILE\r
-               OVER +  \ add N to sum\r
-               SWAP 1- SWAP  \ decrement N\r
-           REPEAT\r
-           SWAP DROP  \ get rid on N\r
-       ;\r
-\r
-: SUM.OF.N.B  ( N -- SUM[N] )\r
-    0 SWAP  \ starting value of SUM\r
-    1+ 0    \ set indices for DO LOOP\r
-    ?DO     \ safer than DO if N=0\r
-        I +\r
-    LOOP\r
-;\r
-\r
-: SUM.OF.N.C  ( N -- SUM[N] )\r
-    0  \ starting value of SUM\r
-    BEGIN   ( -- N' SUM )\r
-       OVER +\r
-       SWAP 1- SWAP\r
-       OVER 0<\r
-    UNTIL\r
-    SWAP DROP\r
-;\r
-\r
-: SUM.OF.N.D  ( N -- SUM[N] )\r
-       >R  \ put NUM on return stack\r
-    0  \ starting value of SUM\r
-    BEGIN   ( -- SUM )\r
-       R@ +  \ add num to sum\r
-       R> 1- DUP >R\r
-       0<\r
-    UNTIL\r
-    RDROP  \ get rid of NUM\r
-;\r
-\r
-: SUM.OF.N.E  { NUM | SUM -- SUM[N] , use return stack }\r
-    BEGIN  \r
-       NUM +-> SUM \ add NUM to SUM\r
-       -1 +-> NUM  \ decrement NUM\r
-       NUM 0<\r
-    UNTIL\r
-    SUM  \ return SUM\r
-;\r
-\r
-: SUM.OF.N.F  ( NUM -- SUM[N] , Gauss' method )\r
-    DUP 1+ * 2/\r
-;\r
-\r
-\r
-: TTT\r
-       10 0\r
-       DO\r
-               I SUM.OF.N.A .\r
-               I SUM.OF.N.B .\r
-               I SUM.OF.N.C .\r
-               I SUM.OF.N.D .\r
-               I SUM.OF.N.E .\r
-               I SUM.OF.N.F .\r
-               CR\r
-       LOOP\r
-;\r
-TTT\r
-\r
+anew task-tut.fth
+
+: SUM.OF.N.A ( N -- SUM[N] , calculate sum of N integers )
+           0  \ starting value of SUM
+           BEGIN
+               OVER 0>   \ Is N greater than zero?
+           WHILE
+               OVER +  \ add N to sum
+               SWAP 1- SWAP  \ decrement N
+           REPEAT
+           SWAP DROP  \ get rid on N
+       ;
+
+: SUM.OF.N.B  ( N -- SUM[N] )
+    0 SWAP  \ starting value of SUM
+    1+ 0    \ set indices for DO LOOP
+    ?DO     \ safer than DO if N=0
+        I +
+    LOOP
+;
+
+: SUM.OF.N.C  ( N -- SUM[N] )
+    0  \ starting value of SUM
+    BEGIN   ( -- N' SUM )
+        OVER +
+        SWAP 1- SWAP
+        OVER 0<
+    UNTIL
+    SWAP DROP
+;
+
+: SUM.OF.N.D  ( N -- SUM[N] )
+    >R  \ put NUM on return stack
+    0  \ starting value of SUM
+    BEGIN   ( -- SUM )
+        R@ +  \ add num to sum
+        R> 1- DUP >R
+        0<
+    UNTIL
+    RDROP  \ get rid of NUM
+;
+
+: SUM.OF.N.E  { NUM | SUM -- SUM[N] , use return stack }
+    BEGIN
+        NUM +-> SUM \ add NUM to SUM
+        -1 +-> NUM  \ decrement NUM
+        NUM 0<
+    UNTIL
+    SUM  \ return SUM
+;
+
+: SUM.OF.N.F  ( NUM -- SUM[N] , Gauss' method )
+    DUP 1+ * 2/
+;
+
+
+: TTT
+    10 0
+    DO
+        I SUM.OF.N.A .
+        I SUM.OF.N.B .
+        I SUM.OF.N.C .
+        I SUM.OF.N.D .
+        I SUM.OF.N.E .
+        I SUM.OF.N.F .
+        CR
+    LOOP
+;
+TTT
+

diff --git a/fth/utils/clone.fth b/fth/utils/clone.fth
index 99c0297..98254b5 100644 (file)
--- a/fth/utils/clone.fth
+++ b/fth/utils/clone.fth
@@ -1,489 +1,489 @@
-\ @(#) clone.fth 97/12/10 1.1\r
-\ Clone for PForth\r
-\\r
-\ Create the smallest dictionary required to run an application.\r
-\\r
-\ Clone decompiles the Forth dictionary starting with the top\r
-\ word in the program.  It then moves all referenced secondaries\r
-\ into a new dictionary.\r
-\\r
-\ This work was inspired by the CLONE feature that Mike Haas wrote\r
-\ for JForth.  Mike's CLONE disassembled 68000 machine code then\r
-\ reassembled it which is much more difficult.\r
-\\r
-\ Copyright Phil Burk & 3DO 1994\r
-\\r
-\ O- trap custom 'C' calls\r
-\ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']\r
-\r
-anew task-clone.fth\r
-decimal\r
-\r
-\ move to 'C'\r
-: PRIMITIVE? ( xt -- flag , true if primitive )\r
-       ['] FIRST_COLON <\r
-;\r
-\r
-: 'SELF ( -- xt , return xt of word being compiled )\r
-       ?comp\r
-       latest name>\r
-       [compile] literal\r
-; immediate\r
-\r
-\r
-:struct CL.REFERENCE\r
-       long  clr_OriginalXT    \ original XT of word\r
-       long  clr_NewXT         \ corresponding XT in cloned dictionary\r
-       long  clr_TotalSize     \ size including data in body\r
-;struct\r
-\r
-variable CL-INITIAL-REFS \ initial number of refs to allocate\r
-100 cl-initial-refs !\r
-variable CL-REF-LEVEL    \ level of threading while scanning\r
-variable CL-NUM-REFS     \ number of secondaries referenced\r
-variable CL-MAX-REFS     \ max number of secondaries allocated\r
-variable CL-LEVEL-MAX    \ max level reached while scanning\r
-variable CL-LEVEL-ABORT  \ max level before aborting\r
-10 cl-level-abort !\r
-variable CL-REFERENCES   \ pointer to cl.reference array\r
-variable CL-TRACE        \ print debug stuff if true\r
-\r
-\ Cloned dictionary builds in allocated memory but XTs are relative\r
-\ to normal code-base, if CL-TEST-MODE true.\r
-variable CL-TEST-MODE\r
- \r
-variable CL-INITIAL-DICT \ initial size of dict to allocate\r
-20 1024 * cl-initial-dict !\r
-variable CL-DICT-SIZE    \ size of allocated cloned dictionary\r
-variable CL-DICT-BASE    \ pointer to virtual base of cloned dictionary\r
-variable CL-DICT-ALLOC   \ pointer to allocated dictionary memory\r
-variable CL-DICT-PTR     \ rel pointer index into cloned dictionary\r
-0 cl-dict-base !\r
-\r
-       \r
-: CL.INDENT ( -- )\r
-       cl-ref-level @ 2* 2* spaces\r
-;\r
-: CL.DUMP.NAME ( xt -- )\r
-       cl.indent\r
-       >name id. cr\r
-;\r
-\r
-: CL.DICT[] ( relptr -- addr )\r
-       cl-dict-base @ +\r
-;\r
-\r
-: CL,  ( cell -- , comma into clone dictionary )\r
-       cl-dict-ptr @ cl.dict[] !\r
-       cell cl-dict-ptr +!\r
-;\r
-\r
-\r
-: CL.FREE.DICT ( -- , free dictionary we built into )\r
-       cl-dict-alloc @ ?dup\r
-       IF\r
-               free dup ?error\r
-               0 cl-dict-alloc !\r
-       THEN\r
-;\r
-\r
-: CL.FREE.REFS ( -- , free dictionary we built into )\r
-       cl-references @ ?dup\r
-       IF\r
-               free dup ?error\r
-               0 cl-references !\r
-       THEN\r
-;\r
-\r
-: CL.ALLOC.REFS ( --  , allocate references to track )\r
-       cl-initial-refs @  \ initial number of references\r
-       dup cl-max-refs ! \ maximum allowed\r
-       sizeof() cl.reference *\r
-       allocate dup ?error\r
-       cl-references !\r
-;\r
-\r
-: CL.RESIZE.REFS ( -- , allocate references to track )\r
-       cl-max-refs @   \ current number of references allocated\r
-       5 * 4 / dup cl-max-refs ! \ new maximum allowed\r
-\ cl.indent ." Resize # references to " dup . cr\r
-       sizeof() cl.reference *\r
-       cl-references @ swap resize dup ?error\r
-       cl-references !\r
-;\r
-\r
-\r
-: CL.ALLOC.DICT ( -- , allocate dictionary to build into )\r
-       cl-initial-dict @  \ initial dictionary size\r
-       dup cl-dict-size !\r
-       allocate dup ?error\r
-       cl-dict-alloc !\r
-\\r
-\ kludge dictionary if testing\r
-       cl-test-mode @\r
-       IF\r
-               cl-dict-alloc @ code-base @ - cl-dict-ptr +!\r
-               code-base @ cl-dict-base !\r
-       ELSE\r
-               cl-dict-alloc @  cl-dict-base !\r
-       THEN\r
-       ." CL.ALLOC.DICT" cr\r
-       ."   cl-dict-alloc = $" cl-dict-alloc @ .hex cr\r
-       ."   cl-dict-base  = $" cl-dict-base @ .hex cr\r
-       ."   cl-dict-ptr   = $" cl-dict-ptr @ .hex cr\r
-;\r
-\r
-: CODEADDR>DATASIZE { code-addr -- datasize }\r
-\ Determine size of any literal data following execution token.\r
-\ Examples are text following (."), or branch offsets.\r
-       code-addr @\r
-       CASE\r
-       ['] (literal) OF cell ENDOF   \ a number\r
-       ['] 0branch   OF cell ENDOF   \ branch offset\r
-       ['] branch    OF cell ENDOF\r
-       ['] (do)      OF    0 ENDOF\r
-       ['] (?do)     OF cell ENDOF\r
-       ['] (loop)    OF cell ENDOF\r
-       ['] (+loop)   OF cell ENDOF\r
-       ['] (.")      OF code-addr cell+ c@ 1+ ENDOF  \ text\r
-       ['] (s")      OF code-addr cell+ c@ 1+ ENDOF\r
-       ['] (c")      OF code-addr cell+ c@ 1+ ENDOF\r
-       0 swap\r
-       ENDCASE\r
-;\r
-\r
-: XT>SIZE  ( xt -- wordsize , including code and data )\r
-       dup >code\r
-       swap >name\r
-       dup latest =\r
-       IF\r
-               drop here\r
-       ELSE\r
-               dup c@ 1+ + aligned 8 + \ get next name\r
-               name> >code \ where is next word\r
-       THEN\r
-       swap -\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize --  }\r
-\ scan secondary and pass each code-address to ca-process\r
-\ CA-PROCESS ( code-addr -- , required stack action for vector )\r
-       1 cl-ref-level +!\r
-       cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"\r
-       BEGIN\r
-               code-addr @ -> xt\r
-\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr\r
-               code-addr codeaddr>datasize -> dsize      \ any data after this?\r
-               code-addr ca-process execute              \ process it\r
-               code-addr cell+ dsize + aligned -> code-addr  \ skip past data\r
-\ !!! Bummer! EXIT called in middle of secondary will cause early stop.\r
-               xt  ['] EXIT  =                           \ stop when we get to EXIT\r
-       UNTIL\r
-       -1 cl-ref-level +!\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-\r
-: CL.DUMP.XT ( xt -- )\r
-       cl-trace @\r
-       IF\r
-               dup primitive?\r
-               IF   ." PRI:  "\r
-               ELSE ." SEC:  "\r
-               THEN\r
-               cl.dump.name\r
-       ELSE\r
-               drop\r
-       THEN\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-: CL.REF[] ( index -- clref )\r
-       sizeof() cl.reference *\r
-       cl-references @ +\r
-;\r
-\r
-: CL.DUMP.REFS ( -- , print references )\r
-       cl-num-refs @ 0\r
-       DO\r
-               i 3 .r ."  : "\r
-               i cl.ref[]\r
-               dup s@ clr_OriginalXT >name id. ."  => "\r
-               dup s@ clr_NewXT .\r
-               ." , size = "\r
-               dup s@ clr_TotalSize . cr\r
-               drop \ clref\r
-       loop\r
-;                      \r
-               \r
-: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found }\r
-       BEGIN\r
-\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr\r
-               indx cl-num-refs @ >=\r
-               IF\r
-                       true\r
-               ELSE\r
-                       indx cl.ref[] s@ clr_OriginalXT\r
-\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr\r
-                       xt  =\r
-                       IF\r
-                               true\r
-                               dup -> flag\r
-                       ELSE\r
-                               false\r
-                               indx 1+ -> indx\r
-                       THEN\r
-               THEN\r
-       UNTIL\r
-       indx flag\r
-\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space  indx . flag . cr\r
-;                      \r
-\r
-: CL.ADD.REF  { xt | clref -- , add referenced secondary to list }\r
-       cl-references @ 0= abort" CL.ADD.REF - References not allocated!"\r
-\\r
-\ do we need to allocate more room?\r
-       cl-num-refs @ cl-max-refs @ >=\r
-       IF\r
-               cl.resize.refs\r
-       THEN\r
-\\r
-       cl-num-refs @ cl.ref[] -> clref    \ index into array\r
-       xt clref s! clr_OriginalXT\r
-       0 clref s! clr_NewXT\r
-       xt xt>size clref s! clr_TotalSize\r
-\\r
-       1 cl-num-refs +!\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-\r
-\ called by cl.traverse.secondary to compile each piece of secondary\r
-: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- ,  }\r
-\ recompile to new location\r
-\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr\r
-       code-addr @ -> xt\r
-\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr\r
-       xt cl.dump.xt\r
-       xt primitive?\r
-       IF\r
-               xt cl,\r
-       ELSE\r
-               xt CL.XT>REF_INDEX\r
-               IF\r
-                       cl.ref[] -> clref\r
-                       clref s@ clr_NewXT\r
-                       dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"\r
-                       cl,\r
-               ELSE\r
-                       cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr\r
-                       abort\r
-               THEN\r
-       THEN\r
-\\r
-\ transfer any literal data\r
-       code-addr codeaddr>datasize -> dsize\r
-       dsize 0>\r
-       IF\r
-\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr\r
-               code-addr cell+  cl-dict-ptr @ cl.dict[]  dsize  move\r
-               cl-dict-ptr @ dsize + aligned cl-dict-ptr !\r
-       THEN\r
-\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr\r
-;\r
-\r
-: CL.RECOMPILE.REF { indx | clref codesize datasize -- }\r
-\ all references have been resolved so recompile new secondary\r
-       depth >r\r
-       indx cl.ref[] -> clref\r
-       cl-trace @\r
-       IF\r
-               cl.indent\r
-               clref s@ clr_OriginalXT >name id. ."  recompiled at $"\r
-               cl-dict-ptr @ .hex cr    \ new address\r
-       THEN\r
-       cl-dict-ptr @  clref s! clr_NewXT\r
-\\r
-\ traverse this secondary and compile into new dictionary\r
-       clref s@ clr_OriginalXT\r
-       >code ['] cl.recompile.secondary cl.traverse.secondary\r
-\\r
-\ determine whether there is any data following definition\r
-       cl-dict-ptr @\r
-       clref s@ clr_NewXT - -> codesize \ size of cloned code\r
-       clref s@ clr_TotalSize \ total bytes\r
-       codesize - -> datasize\r
-       cl-trace @\r
-       IF\r
-               cl.indent\r
-               ." Move data: data size = " datasize . ." codesize = " codesize . cr\r
-       THEN\r
-\\r
-\ copy any data that followed definition\r
-       datasize 0>\r
-       IF\r
-               clref s@ clr_OriginalXT >code codesize +\r
-               clref s@ clr_NewXT cl-dict-base @ + codesize +\r
-               datasize move\r
-               datasize cl-dict-ptr +!  \ allot space in clone dictionary\r
-       THEN\r
-       \r
-       depth r> - abort" Stack depth change in CL.RECOMPILE.REF"\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )\r
-       depth 1- >r\r
-\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr\r
-       cl-ref-level @ cl-level-max @  MAX cl-level-max !\r
-       @ ( get xt )\r
-\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr\r
-       dup cl.dump.xt\r
-       dup primitive?\r
-       IF\r
-               drop\r
-\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr\r
-       ELSE\r
-               dup CL.XT>REF_INDEX\r
-               IF\r
-                       drop \ indx   \ already referenced once so ignore\r
-                       drop \ xt\r
-               ELSE\r
-                       >r \ indx\r
-                       dup cl.add.ref\r
-                       >code 'self cl.traverse.secondary   \ use 'self for recursion!\r
-                       r> cl.recompile.ref    \ now that all refs resolved, recompile\r
-               THEN\r
-       THEN\r
-\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr\r
-       depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"\r
-;\r
-\r
-: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list )\r
-       dup primitive? abort" Cannot CLONE a PRIMITIVE word!"\r
-       0 cl-ref-level !\r
-       0 cl-level-max !\r
-       0 cl-num-refs !\r
-       dup cl.add.ref     \ word being cloned is top of ref list\r
-       >code ['] cl.scan.secondary cl.traverse.secondary\r
-       0 cl.recompile.ref\r
-;\r
-\r
-\ ------------------------------------------------------------------\r
-: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict )\r
-       cl.xt>ref_index 0= abort" not in cloned dictionary!"\r
-       cl.ref[] s@ clr_NewXT\r
-;\r
-: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )\r
-       cl.xt>New_XT\r
-       cl-dict-base @ +\r
-;\r
-\r
-: CL.REPORT ( -- )\r
-       ." Clone scan went " cl-level-max @ . ." levels deep." cr\r
-       ." Clone scanned " cl-num-refs @ . ." secondaries." cr\r
-       ." New dictionary size =  " cl-dict-ptr @ cl-dict-base @ - . cr\r
-;\r
-\r
-\r
-\ ------------------------------------------------------------------\r
-: CL.TERM ( -- , cleanup )\r
-       cl.free.refs\r
-       cl.free.dict\r
-;\r
-\r
-: CL.INIT ( -- )\r
-       cl.term\r
-       0 cl-dict-size !\r
-       ['] first_colon cl-dict-ptr !\r
-       cl.alloc.dict\r
-       cl.alloc.refs\r
-;\r
-\r
-: 'CLONE ( xt -- , clone dictionary from this word )\r
-       cl.init\r
-       cl.clone.xt\r
-       cl.report\r
-       cl.dump.refs\r
-       cl-test-mode @\r
-       IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr\r
-       THEN\r
-;\r
-\r
-: SAVE-CLONE  ( <filename> -- )\r
-       bl word\r
-       ." Save cloned image in " dup count type\r
-       drop ." SAVE-CLONE unimplemented!" \ %Q\r
-;\r
-\r
-: CLONE ( <name> -- )\r
-       ' 'clone\r
-;\r
-\r
-if.forgotten cl.term\r
-\r
-\ ---------------------------------- TESTS --------------------\r
-\r
-\r
-: TEST.CLONE ( -- )\r
-       cl-test-mode @ not abort" CL-TEST-MODE not on!"\r
-       0 cl.ref[] s@ clr_NewXT  execute\r
-;\r
-\r
-\r
-: TEST.CLONE.REAL ( -- )\r
-       cl-test-mode @ abort" CL-TEST-MODE on!"\r
-       code-base @\r
-       0 cl.ref[] s@ clr_NewXT  \ get cloned execution token\r
-       cl-dict-base @ code-base !\r
-\ WARNING - code-base munged, only execute primitives or cloned code\r
-       execute\r
-       code-base !   \ restore code base for normal \r
-;\r
-\r
-\r
-: TCL1\r
-       34 dup +\r
-;\r
-\r
-: TCL2\r
-       ." Hello " tcl1  . cr\r
-;\r
-\r
-: TCL3\r
-       4 0\r
-       DO\r
-               tcl2\r
-               i . cr\r
-               i 100 + . cr\r
-       LOOP\r
-;\r
-\r
-create VAR1 567 ,\r
-: TCL4\r
-       345 var1 !\r
-       ." VAR1 = " var1 @ . cr\r
-       var1 @ 345 -\r
-       IF\r
-               ." TCL4 failed!" cr\r
-       ELSE\r
-               ." TCL4 succeded! Yay!" cr\r
-       THEN\r
-;\r
-\r
-\ do deferred words get cloned!\r
-defer tcl.vector\r
-\r
-: TCL.DOIT ." Hello Fred!" cr ;\r
-' tcl.doit is tcl.vector\r
-\r
-: TCL.DEFER\r
-       12 . cr\r
-       tcl.vector\r
-       999 dup + . cr\r
-;\r
-\r
-trace-stack on\r
-cl-test-mode on\r
-\r
+\ @(#) clone.fth 97/12/10 1.1
+\ Clone for PForth
+\
+\ Create the smallest dictionary required to run an application.
+\
+\ Clone decompiles the Forth dictionary starting with the top
+\ word in the program.  It then moves all referenced secondaries
+\ into a new dictionary.
+\
+\ This work was inspired by the CLONE feature that Mike Haas wrote
+\ for JForth.  Mike's CLONE disassembled 68000 machine code then
+\ reassembled it which is much more difficult.
+\
+\ Copyright Phil Burk & 3DO 1994
+\
+\ O- trap custom 'C' calls
+\ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']
+
+anew task-clone.fth
+decimal
+
+\ move to 'C'
+: PRIMITIVE? ( xt -- flag , true if primitive )
+    ['] FIRST_COLON <
+;
+
+: 'SELF ( -- xt , return xt of word being compiled )
+    ?comp
+    latest name>
+    [compile] literal
+; immediate
+
+
+:struct CL.REFERENCE
+    long  clr_OriginalXT    \ original XT of word
+    long  clr_NewXT         \ corresponding XT in cloned dictionary
+    long  clr_TotalSize     \ size including data in body
+;struct
+
+variable CL-INITIAL-REFS \ initial number of refs to allocate
+100 cl-initial-refs !
+variable CL-REF-LEVEL    \ level of threading while scanning
+variable CL-NUM-REFS     \ number of secondaries referenced
+variable CL-MAX-REFS     \ max number of secondaries allocated
+variable CL-LEVEL-MAX    \ max level reached while scanning
+variable CL-LEVEL-ABORT  \ max level before aborting
+10 cl-level-abort !
+variable CL-REFERENCES   \ pointer to cl.reference array
+variable CL-TRACE        \ print debug stuff if true
+
+\ Cloned dictionary builds in allocated memory but XTs are relative
+\ to normal code-base, if CL-TEST-MODE true.
+variable CL-TEST-MODE
+
+variable CL-INITIAL-DICT \ initial size of dict to allocate
+20 1024 * cl-initial-dict !
+variable CL-DICT-SIZE    \ size of allocated cloned dictionary
+variable CL-DICT-BASE    \ pointer to virtual base of cloned dictionary
+variable CL-DICT-ALLOC   \ pointer to allocated dictionary memory
+variable CL-DICT-PTR     \ rel pointer index into cloned dictionary
+0 cl-dict-base !
+
+
+: CL.INDENT ( -- )
+    cl-ref-level @ 2* 2* spaces
+;
+: CL.DUMP.NAME ( xt -- )
+    cl.indent
+    >name id. cr
+;
+
+: CL.DICT[] ( relptr -- addr )
+    cl-dict-base @ +
+;
+
+: CL,  ( cell -- , comma into clone dictionary )
+    cl-dict-ptr @ cl.dict[] !
+    cell cl-dict-ptr +!
+;
+
+
+: CL.FREE.DICT ( -- , free dictionary we built into )
+    cl-dict-alloc @ ?dup
+    IF
+        free dup ?error
+        0 cl-dict-alloc !
+    THEN
+;
+
+: CL.FREE.REFS ( -- , free dictionary we built into )
+    cl-references @ ?dup
+    IF
+        free dup ?error
+        0 cl-references !
+    THEN
+;
+
+: CL.ALLOC.REFS ( --  , allocate references to track )
+    cl-initial-refs @  \ initial number of references
+    dup cl-max-refs ! \ maximum allowed
+    sizeof() cl.reference *
+    allocate dup ?error
+    cl-references !
+;
+
+: CL.RESIZE.REFS ( -- , allocate references to track )
+    cl-max-refs @   \ current number of references allocated
+    5 * 4 / dup cl-max-refs ! \ new maximum allowed
+\ cl.indent ." Resize # references to " dup . cr
+    sizeof() cl.reference *
+    cl-references @ swap resize dup ?error
+    cl-references !
+;
+
+
+: CL.ALLOC.DICT ( -- , allocate dictionary to build into )
+    cl-initial-dict @  \ initial dictionary size
+    dup cl-dict-size !
+    allocate dup ?error
+    cl-dict-alloc !
+\
+\ kludge dictionary if testing
+    cl-test-mode @
+    IF
+        cl-dict-alloc @ code-base @ - cl-dict-ptr +!
+        code-base @ cl-dict-base !
+    ELSE
+        cl-dict-alloc @  cl-dict-base !
+    THEN
+    ." CL.ALLOC.DICT" cr
+    ."   cl-dict-alloc = $" cl-dict-alloc @ .hex cr
+    ."   cl-dict-base  = $" cl-dict-base @ .hex cr
+    ."   cl-dict-ptr   = $" cl-dict-ptr @ .hex cr
+;
+
+: CODEADDR>DATASIZE { code-addr -- datasize }
+\ Determine size of any literal data following execution token.
+\ Examples are text following (."), or branch offsets.
+    code-addr @
+    CASE
+    ['] (literal) OF cell ENDOF   \ a number
+    ['] 0branch   OF cell ENDOF   \ branch offset
+    ['] branch    OF cell ENDOF
+    ['] (do)      OF    0 ENDOF
+    ['] (?do)     OF cell ENDOF
+    ['] (loop)    OF cell ENDOF
+    ['] (+loop)   OF cell ENDOF
+    ['] (.")      OF code-addr cell+ c@ 1+ ENDOF  \ text
+    ['] (s")      OF code-addr cell+ c@ 1+ ENDOF
+    ['] (c")      OF code-addr cell+ c@ 1+ ENDOF
+    0 swap
+    ENDCASE
+;
+
+: XT>SIZE  ( xt -- wordsize , including code and data )
+    dup >code
+    swap >name
+    dup latest =
+    IF
+        drop here
+    ELSE
+        dup c@ 1+ + aligned 8 + \ get next name
+        name> >code \ where is next word
+    THEN
+    swap -
+;
+
+\ ------------------------------------------------------------------
+: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize --  }
+\ scan secondary and pass each code-address to ca-process
+\ CA-PROCESS ( code-addr -- , required stack action for vector )
+    1 cl-ref-level +!
+    cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"
+    BEGIN
+        code-addr @ -> xt
+\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr
+        code-addr codeaddr>datasize -> dsize      \ any data after this?
+        code-addr ca-process execute              \ process it
+        code-addr cell+ dsize + aligned -> code-addr  \ skip past data
+\ !!! Bummer! EXIT called in middle of secondary will cause early stop.
+        xt  ['] EXIT  =                           \ stop when we get to EXIT
+    UNTIL
+    -1 cl-ref-level +!
+;
+
+\ ------------------------------------------------------------------
+
+: CL.DUMP.XT ( xt -- )
+    cl-trace @
+    IF
+        dup primitive?
+        IF   ." PRI:  "
+        ELSE ." SEC:  "
+        THEN
+        cl.dump.name
+    ELSE
+        drop
+    THEN
+;
+
+\ ------------------------------------------------------------------
+: CL.REF[] ( index -- clref )
+    sizeof() cl.reference *
+    cl-references @ +
+;
+
+: CL.DUMP.REFS ( -- , print references )
+    cl-num-refs @ 0
+    DO
+        i 3 .r ."  : "
+        i cl.ref[]
+        dup s@ clr_OriginalXT >name id. ."  => "
+        dup s@ clr_NewXT .
+        ." , size = "
+        dup s@ clr_TotalSize . cr
+        drop \ clref
+    loop
+;
+
+: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found }
+    BEGIN
+\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr
+        indx cl-num-refs @ >=
+        IF
+            true
+        ELSE
+            indx cl.ref[] s@ clr_OriginalXT
+\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr
+            xt  =
+            IF
+                true
+                dup -> flag
+            ELSE
+                false
+                indx 1+ -> indx
+            THEN
+        THEN
+    UNTIL
+    indx flag
+\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space  indx . flag . cr
+;
+
+: CL.ADD.REF  { xt | clref -- , add referenced secondary to list }
+    cl-references @ 0= abort" CL.ADD.REF - References not allocated!"
+\
+\ do we need to allocate more room?
+    cl-num-refs @ cl-max-refs @ >=
+    IF
+        cl.resize.refs
+    THEN
+\
+    cl-num-refs @ cl.ref[] -> clref    \ index into array
+    xt clref s! clr_OriginalXT
+    0 clref s! clr_NewXT
+    xt xt>size clref s! clr_TotalSize
+\
+    1 cl-num-refs +!
+;
+
+\ ------------------------------------------------------------------
+
+\ called by cl.traverse.secondary to compile each piece of secondary
+: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- ,  }
+\ recompile to new location
+\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr
+    code-addr @ -> xt
+\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr
+    xt cl.dump.xt
+    xt primitive?
+    IF
+        xt cl,
+    ELSE
+        xt CL.XT>REF_INDEX
+        IF
+            cl.ref[] -> clref
+            clref s@ clr_NewXT
+            dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"
+            cl,
+        ELSE
+            cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr
+            abort
+        THEN
+    THEN
+\
+\ transfer any literal data
+    code-addr codeaddr>datasize -> dsize
+    dsize 0>
+    IF
+\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr
+        code-addr cell+  cl-dict-ptr @ cl.dict[]  dsize  move
+        cl-dict-ptr @ dsize + aligned cl-dict-ptr !
+    THEN
+\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr
+;
+
+: CL.RECOMPILE.REF { indx | clref codesize datasize -- }
+\ all references have been resolved so recompile new secondary
+    depth >r
+    indx cl.ref[] -> clref
+    cl-trace @
+    IF
+        cl.indent
+        clref s@ clr_OriginalXT >name id. ."  recompiled at $"
+        cl-dict-ptr @ .hex cr    \ new address
+    THEN
+    cl-dict-ptr @  clref s! clr_NewXT
+\
+\ traverse this secondary and compile into new dictionary
+    clref s@ clr_OriginalXT
+    >code ['] cl.recompile.secondary cl.traverse.secondary
+\
+\ determine whether there is any data following definition
+    cl-dict-ptr @
+    clref s@ clr_NewXT - -> codesize \ size of cloned code
+    clref s@ clr_TotalSize \ total bytes
+    codesize - -> datasize
+    cl-trace @
+    IF
+        cl.indent
+        ." Move data: data size = " datasize . ." codesize = " codesize . cr
+    THEN
+\
+\ copy any data that followed definition
+    datasize 0>
+    IF
+        clref s@ clr_OriginalXT >code codesize +
+        clref s@ clr_NewXT cl-dict-base @ + codesize +
+        datasize move
+        datasize cl-dict-ptr +!  \ allot space in clone dictionary
+    THEN
+
+    depth r> - abort" Stack depth change in CL.RECOMPILE.REF"
+;
+
+\ ------------------------------------------------------------------
+: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )
+    depth 1- >r
+\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr
+    cl-ref-level @ cl-level-max @  MAX cl-level-max !
+    @ ( get xt )
+\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr
+    dup cl.dump.xt
+    dup primitive?
+    IF
+        drop
+\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr
+    ELSE
+        dup CL.XT>REF_INDEX
+        IF
+            drop \ indx   \ already referenced once so ignore
+            drop \ xt
+        ELSE
+            >r \ indx
+            dup cl.add.ref
+            >code 'self cl.traverse.secondary   \ use 'self for recursion!
+            r> cl.recompile.ref    \ now that all refs resolved, recompile
+        THEN
+    THEN
+\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr
+    depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"
+;
+
+: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list )
+    dup primitive? abort" Cannot CLONE a PRIMITIVE word!"
+    0 cl-ref-level !
+    0 cl-level-max !
+    0 cl-num-refs !
+    dup cl.add.ref     \ word being cloned is top of ref list
+    >code ['] cl.scan.secondary cl.traverse.secondary
+    0 cl.recompile.ref
+;
+
+\ ------------------------------------------------------------------
+: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict )
+    cl.xt>ref_index 0= abort" not in cloned dictionary!"
+    cl.ref[] s@ clr_NewXT
+;
+: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )
+    cl.xt>New_XT
+    cl-dict-base @ +
+;
+
+: CL.REPORT ( -- )
+    ." Clone scan went " cl-level-max @ . ." levels deep." cr
+    ." Clone scanned " cl-num-refs @ . ." secondaries." cr
+    ." New dictionary size =  " cl-dict-ptr @ cl-dict-base @ - . cr
+;
+
+
+\ ------------------------------------------------------------------
+: CL.TERM ( -- , cleanup )
+    cl.free.refs
+    cl.free.dict
+;
+
+: CL.INIT ( -- )
+    cl.term
+    0 cl-dict-size !
+    ['] first_colon cl-dict-ptr !
+    cl.alloc.dict
+    cl.alloc.refs
+;
+
+: 'CLONE ( xt -- , clone dictionary from this word )
+    cl.init
+    cl.clone.xt
+    cl.report
+    cl.dump.refs
+    cl-test-mode @
+    IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr
+    THEN
+;
+
+: SAVE-CLONE  ( <filename> -- )
+    bl word
+    ." Save cloned image in " dup count type
+    drop ." SAVE-CLONE unimplemented!" \ %Q
+;
+
+: CLONE ( <name> -- )
+    ' 'clone
+;
+
+if.forgotten cl.term
+
+\ ---------------------------------- TESTS --------------------
+
+
+: TEST.CLONE ( -- )
+    cl-test-mode @ not abort" CL-TEST-MODE not on!"
+    0 cl.ref[] s@ clr_NewXT  execute
+;
+
+
+: TEST.CLONE.REAL ( -- )
+    cl-test-mode @ abort" CL-TEST-MODE on!"
+    code-base @
+    0 cl.ref[] s@ clr_NewXT  \ get cloned execution token
+    cl-dict-base @ code-base !
+\ WARNING - code-base munged, only execute primitives or cloned code
+    execute
+    code-base !   \ restore code base for normal
+;
+
+
+: TCL1
+    34 dup +
+;
+
+: TCL2
+    ." Hello " tcl1  . cr
+;
+
+: TCL3
+    4 0
+    DO
+        tcl2
+        i . cr
+        i 100 + . cr
+    LOOP
+;
+
+create VAR1 567 ,
+: TCL4
+    345 var1 !
+    ." VAR1 = " var1 @ . cr
+    var1 @ 345 -
+    IF
+        ." TCL4 failed!" cr
+    ELSE
+        ." TCL4 succeded! Yay!" cr
+    THEN
+;
+
+\ do deferred words get cloned!
+defer tcl.vector
+
+: TCL.DOIT ." Hello Fred!" cr ;
+' tcl.doit is tcl.vector
+
+: TCL.DEFER
+    12 . cr
+    tcl.vector
+    999 dup + . cr
+;
+
+trace-stack on
+cl-test-mode on
+

diff --git a/fth/utils/dump_struct.fth b/fth/utils/dump_struct.fth
index 39a32c0..5010e57 100644 (file)
--- a/fth/utils/dump_struct.fth
+++ b/fth/utils/dump_struct.fth
@@ -1,122 +1,122 @@
-\ @(#) dump_struct.fth 97/12/10 1.1\r
-\ Dump contents of structure showing values and member names.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1987 Phil Burk\r
-\ All Rights Reserved.\r
-\\r
-\ MOD: PLB 9/4/88 Print size too.\r
-\ MOD: PLB 9/9/88 Print U/S , add ADST\r
-\ MOD: PLB 12/6/90 Modified to work with H4th\r
-\ 941109 PLB Converted to pforth.  Added RP detection.\r
-\ 090609 PLB Convert >rel to use->rel and ..! to s!\r
-\r
-include? task-member.fth member.fth\r
-include? task-c_struct c_struct.fth\r
-\r
-ANEW TASK-DUMP_STRUCT\r
-\r
-: EMIT-TO-COLUMN ( char col -- )\r
-       out @ - 0 max 80 min 0\r
-       DO  dup emit\r
-       LOOP drop\r
-;\r
-\r
-VARIABLE SN-FENCE\r
-: STACK.NFAS  ( fencenfa topnfa -- 0 nfa0 nfa1 ... )\r
-\ Fill stack with nfas of words until fence hit.\r
-    >r sn-fence !\r
-    0 r>  ( set terminator )\r
-    BEGIN ( -- 0 n0 n1 ... top )\r
-      dup sn-fence @ >\r
-    WHILE\r
-\      dup n>link @   \ JForth\r
-       dup prevname   \ HForth\r
-    REPEAT\r
-    drop\r
-;\r
-\r
-: DST.DUMP.TYPE  ( +-size -- , dump data type, 941109)\r
-       dup abs 4 =\r
-       IF\r
-               0<\r
-               IF ." RP"\r
-               ELSE ." U4"\r
-               THEN\r
-       ELSE\r
-               dup 0<\r
-               IF ascii U\r
-               ELSE ascii S\r
-               THEN emit abs 1 .r\r
-       THEN\r
-;\r
-\r
-: DUMP.MEMBER ( addr member-pfa -- , dump member of structure)\r
-    ob.stats  ( -- addr offset size )\r
-    >r + r> ( -- addr' size )\r
-    dup ABS 4 >  ( -- addr' size flag )\r
-    IF   cr 2dup swap . . ABS dump\r
-    ELSE tuck @bytes 10 .r ( -- size )\r
-        3 spaces dst.dump.type\r
-    THEN\r
-;\r
-\r
-VARIABLE DS-ADDR\r
-: DUMP.STRUCT ( addr-data addr-structure -- )\r
-    >newline swap >r  ( -- as , save addr-data for dumping )\r
-\    dup cell+ @ over +  \ JForth\r
-       dup code> >name swap cell+ @ over +   \ HForth\r
-       stack.nfas   ( fill stack with nfas of members )\r
-    BEGIN\r
-        dup\r
-    WHILE   ( continue until non-zero )\r
-        dup name> >body r@ swap dump.member\r
-        bl 18 emit-to-column id. cr\r
-        ?pause\r
-    REPEAT drop rdrop\r
-;\r
-\r
-: DST ( addr <name> -- , dump contents of structure )\r
-    ob.findit\r
-    state @\r
-    IF [compile] literal compile dump.struct\r
-    ELSE dump.struct\r
-    THEN\r
-; immediate\r
-\r
-: ADST ( absolute_address -- , dump structure )\r
-    use->rel [compile] dst     \ mod 090609\r
-; immediate\r
-\r
-\ For Testing Purposes\r
-false [IF]\r
-:STRUCT GOO\r
-    LONG DATAPTR\r
-    SHORT GOO_WIDTH\r
-    USHORT GOO_HEIGHT\r
-;STRUCT\r
-\r
-:STRUCT FOO\r
-    LONG ALONG1\r
-    STRUCT GOO AGOO\r
-    SHORT ASHORT1\r
-    BYTE ABYTE\r
-    BYTE ABYTE2\r
-;STRUCT\r
-\r
-FOO AFOO\r
-: AFOO.INIT\r
-    $ 12345678 afoo s! along1\r
-    $ -665 afoo s! ashort1\r
-    $ 21 afoo s! abyte\r
-    $ 43 afoo s! abyte2\r
-    -234 afoo .. agoo s! goo_height\r
-;\r
-afoo.init\r
-\r
-: TDS ( afoo -- )\r
-    dst foo\r
-;\r
-\r
-[THEN]\r
-\r
+\ @(#) dump_struct.fth 97/12/10 1.1
+\ Dump contents of structure showing values and member names.
+\
+\ Author: Phil Burk
+\ Copyright 1987 Phil Burk
+\ All Rights Reserved.
+\
+\ MOD: PLB 9/4/88 Print size too.
+\ MOD: PLB 9/9/88 Print U/S , add ADST
+\ MOD: PLB 12/6/90 Modified to work with H4th
+\ 941109 PLB Converted to pforth.  Added RP detection.
+\ 090609 PLB Convert >rel to use->rel and ..! to s!
+
+include? task-member.fth member.fth
+include? task-c_struct c_struct.fth
+
+ANEW TASK-DUMP_STRUCT
+
+: EMIT-TO-COLUMN ( char col -- )
+    out @ - 0 max 80 min 0
+    DO  dup emit
+    LOOP drop
+;
+
+VARIABLE SN-FENCE
+: STACK.NFAS  ( fencenfa topnfa -- 0 nfa0 nfa1 ... )
+\ Fill stack with nfas of words until fence hit.
+    >r sn-fence !
+    0 r>  ( set terminator )
+    BEGIN ( -- 0 n0 n1 ... top )
+      dup sn-fence @ >
+    WHILE
+\      dup n>link @   \ JForth
+       dup prevname   \ HForth
+    REPEAT
+    drop
+;
+
+: DST.DUMP.TYPE  ( +-size -- , dump data type, 941109)
+    dup abs 4 =
+    IF
+        0<
+        IF ." RP"
+        ELSE ." U4"
+        THEN
+    ELSE
+        dup 0<
+            IF ascii U
+            ELSE ascii S
+            THEN emit abs 1 .r
+    THEN
+;
+
+: DUMP.MEMBER ( addr member-pfa -- , dump member of structure)
+    ob.stats  ( -- addr offset size )
+    >r + r> ( -- addr' size )
+    dup ABS 4 >  ( -- addr' size flag )
+    IF   cr 2dup swap . . ABS dump
+    ELSE tuck @bytes 10 .r ( -- size )
+        3 spaces dst.dump.type
+    THEN
+;
+
+VARIABLE DS-ADDR
+: DUMP.STRUCT ( addr-data addr-structure -- )
+    >newline swap >r  ( -- as , save addr-data for dumping )
+\    dup cell+ @ over +  \ JForth
+    dup code> >name swap cell+ @ over +   \ HForth
+    stack.nfas   ( fill stack with nfas of members )
+    BEGIN
+        dup
+    WHILE   ( continue until non-zero )
+        dup name> >body r@ swap dump.member
+        bl 18 emit-to-column id. cr
+        ?pause
+    REPEAT drop rdrop
+;
+
+: DST ( addr <name> -- , dump contents of structure )
+    ob.findit
+    state @
+    IF [compile] literal compile dump.struct
+    ELSE dump.struct
+    THEN
+; immediate
+
+: ADST ( absolute_address -- , dump structure )
+    use->rel [compile] dst     \ mod 090609
+; immediate
+
+\ For Testing Purposes
+false [IF]
+:STRUCT GOO
+    LONG DATAPTR
+    SHORT GOO_WIDTH
+    USHORT GOO_HEIGHT
+;STRUCT
+
+:STRUCT FOO
+    LONG ALONG1
+    STRUCT GOO AGOO
+    SHORT ASHORT1
+    BYTE ABYTE
+    BYTE ABYTE2
+;STRUCT
+
+FOO AFOO
+: AFOO.INIT
+    $ 12345678 afoo s! along1
+    $ -665 afoo s! ashort1
+    $ 21 afoo s! abyte
+    $ 43 afoo s! abyte2
+    -234 afoo .. agoo s! goo_height
+;
+afoo.init
+
+: TDS ( afoo -- )
+    dst foo
+;
+
+[THEN]
+

diff --git a/fth/utils/load_file.fth b/fth/utils/load_file.fth
index 669ffc3..d015c6a 100644 (file)
--- a/fth/utils/load_file.fth
+++ b/fth/utils/load_file.fth
@@ -1,39 +1,39 @@
-\ Load a file into an allocated memory image.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 3DO 1995\r
-\r
-anew task-load_file.fth\r
-\r
-: $LOAD.FILE { $filename | fid numbytes numread err data -- data-addr 0 | 0 err }\r
-       0 -> data\r
-\ open file\r
-       $filename count r/o open-file -> err -> fid\r
-       err\r
-       IF\r
-               ." $LOAD.FILE - Could not open input file!" cr\r
-       ELSE\r
-\ determine size of file\r
-               fid file-size -> err -> numbytes\r
-               err\r
-               IF\r
-                        ." $LOAD.FILE - File size failed!" cr\r
-               ELSE\r
-                       ." File size = " numbytes . cr\r
-\ allocate memory for sample, when done free memory using FREE\r
-                       numbytes allocate -> err -> data\r
-                       err\r
-                       IF\r
-                               ." $LOAD.FILE - Memory allocation failed!" cr\r
-                       ELSE\r
-\ read data\r
-                               data numbytes fid read-file -> err\r
-                               ." Read " . ." bytes from file " $filename count type cr\r
-                       THEN\r
-               THEN\r
-               fid close-file drop\r
-       THEN\r
-       data err\r
-;\r
-\r
-\ Example:   c" myfile" $load.file   abort" Oops!"   free .\r
+\ Load a file into an allocated memory image.
+\
+\ Author: Phil Burk
+\ Copyright 3DO 1995
+
+anew task-load_file.fth
+
+: $LOAD.FILE { $filename | fid numbytes numread err data -- data-addr 0 | 0 err }
+    0 -> data
+\ open file
+    $filename count r/o open-file -> err -> fid
+    err
+    IF
+        ." $LOAD.FILE - Could not open input file!" cr
+    ELSE
+\ determine size of file
+        fid file-size -> err -> numbytes
+        err
+        IF
+             ." $LOAD.FILE - File size failed!" cr
+        ELSE
+            ." File size = " numbytes . cr
+\ allocate memory for sample, when done free memory using FREE
+            numbytes allocate -> err -> data
+            err
+            IF
+                ." $LOAD.FILE - Memory allocation failed!" cr
+            ELSE
+\ read data
+                data numbytes fid read-file -> err
+                ." Read " . ." bytes from file " $filename count type cr
+            THEN
+        THEN
+        fid close-file drop
+    THEN
+    data err
+;
+
+\ Example:   c" myfile" $load.file   abort" Oops!"   free .

diff --git a/fth/utils/make_all256.fth b/fth/utils/make_all256.fth
index 72d2eed..4a12f64 100644 (file)
--- a/fth/utils/make_all256.fth
+++ b/fth/utils/make_all256.fth
@@ -1,57 +1,57 @@
-\ @(#) make_all256.fth 97/12/10 1.1\r
-\ Make a file with all possible 256 bytes in random order.\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1987 Phil Burk\r
-\ All Rights Reserved.\r
-\r
-ANEW TASK-MAKE_ALL256\r
-\r
-variable RAND8-SEED\r
-19 rand8-seed !\r
-: RANDOM8 ( -- r8 , generate random bytes, repeat every 256 )\r
-       RAND8-SEED @\r
-       77 * 55 +\r
-       $ FF and\r
-       dup RAND8-SEED !\r
-;\r
-\r
-create rand8-pad 256 allot\r
-: make.256.data\r
-       256 0\r
-       DO\r
-               random8 rand8-pad i + c!\r
-       LOOP\r
-;\r
-\r
-: SHUFFLE.DATA { num | ind1 ind2 -- }\r
-       num 0\r
-       DO\r
-               256 choose -> ind1\r
-               256 choose -> ind2\r
-               ind1 rand8-pad + c@\r
-               ind2 rand8-pad + c@\r
-               ind1 rand8-pad + c!\r
-               ind2 rand8-pad + c!\r
-       LOOP\r
-;\r
-       \r
-: WRITE.256.FILE   { | fid -- }\r
-       p" all256.raw" count r/w create-file\r
-       IF\r
-               drop ." Could not create file." cr\r
-       ELSE\r
-               -> fid\r
-               fid . cr\r
-               rand8-pad 256 fid write-file abort" write failed!"\r
-               fid close-file drop\r
-       THEN\r
-;\r
-\r
-: MAKE.256.FILE\r
-       make.256.data\r
-       1000 shuffle.data\r
-       write.256.file\r
-;\r
-\r
-MAKE.256.FILE\r
+\ @(#) make_all256.fth 97/12/10 1.1
+\ Make a file with all possible 256 bytes in random order.
+\
+\ Author: Phil Burk
+\ Copyright 1987 Phil Burk
+\ All Rights Reserved.
+
+ANEW TASK-MAKE_ALL256
+
+variable RAND8-SEED
+19 rand8-seed !
+: RANDOM8 ( -- r8 , generate random bytes, repeat every 256 )
+    RAND8-SEED @
+    77 * 55 +
+    $ FF and
+    dup RAND8-SEED !
+;
+
+create rand8-pad 256 allot
+: make.256.data
+    256 0
+    DO
+        random8 rand8-pad i + c!
+    LOOP
+;
+
+: SHUFFLE.DATA { num | ind1 ind2 -- }
+    num 0
+    DO
+        256 choose -> ind1
+        256 choose -> ind2
+        ind1 rand8-pad + c@
+        ind2 rand8-pad + c@
+        ind1 rand8-pad + c!
+        ind2 rand8-pad + c!
+    LOOP
+;
+
+: WRITE.256.FILE   { | fid -- }
+    p" all256.raw" count r/w create-file
+    IF
+        drop ." Could not create file." cr
+    ELSE
+        -> fid
+        fid . cr
+        rand8-pad 256 fid write-file abort" write failed!"
+        fid close-file drop
+    THEN
+;
+
+: MAKE.256.FILE
+    make.256.data
+    1000 shuffle.data
+    write.256.file
+;
+
+MAKE.256.FILE

diff --git a/fth/wordslik.fth b/fth/wordslik.fth
index ff73c63..e5ebd5a 100644 (file)
--- a/fth/wordslik.fth
+++ b/fth/wordslik.fth
@@ -1,44 +1,44 @@
-\ @(#) wordslik.fth 98/01/26 1.2\r
-\\r
-\ WORDS.LIKE  ( <string> -- , search for words that contain string )\r
-\\r
-\ Enter:   WORDS.LIKE +\r
-\ Enter:   WORDS.LIKE EMIT\r
-\\r
-\ Author: Phil Burk\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license.  The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\r
-anew task-wordslik.fth\r
-decimal\r
-\r
-\r
-: PARTIAL.MATCH.NAME  ( $str1 nfa  -- flag , is $str1 in nfa ??? )\r
-       count $ 1F and\r
-       rot count\r
-       search\r
-       >r 2drop r>\r
-;\r
-\r
-: WORDS.LIKE  ( <name> -- , print all words containing substring )\r
-       BL word latest\r
-       >newline\r
-       BEGIN\r
-               prevname dup 0<> \ get previous name in dictionary\r
-       WHILE\r
-               2dup partial.match.name\r
-               IF\r
-                       dup id. tab\r
-                       cr?\r
-               THEN\r
-       REPEAT 2drop\r
-       >newline\r
-;\r
+\ @(#) wordslik.fth 98/01/26 1.2
+\
+\ WORDS.LIKE  ( <string> -- , search for words that contain string )
+\
+\ Enter:   WORDS.LIKE +
+\ Enter:   WORDS.LIKE EMIT
+\
+\ Author: Phil Burk
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
+\
+\ The pForth software code is dedicated to the public domain,
+\ and any third party may reproduce, distribute and modify
+\ the pForth software code or any derivative works thereof
+\ without any compensation or license.  The pForth software
+\ code is provided on an "as is" basis without any 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.
+
+anew task-wordslik.fth
+decimal
+
+
+: PARTIAL.MATCH.NAME  ( $str1 nfa  -- flag , is $str1 in nfa ??? )
+    count $ 1F and
+    rot count
+    search
+    >r 2drop r>
+;
+
+: WORDS.LIKE  ( <name> -- , print all words containing substring )
+    BL word latest
+    >newline
+    BEGIN
+        prevname dup 0<> \ get previous name in dictionary
+    WHILE
+        2dup partial.match.name
+        IF
+            dup id. tab
+            cr?
+        THEN
+    REPEAT 2drop
+    >newline
+;

diff --git a/readme.txt b/readme.txt
index 22fc1ce..de7cf90 100644 (file)
--- a/readme.txt
+++ b/readme.txt
@@ -1,92 +1,92 @@
-README for pForth - a Portable ANS-like Forth written in ANSI 'C'\r
-\r
-by Phil Burk\r
-with Larry Polansky, David Rosenboom and Darren Gibbs.\r
-Support for 64-bit cells by Aleksej Saushev.\r
-\r
-Last updated: December 23, 2014 V27\r
-\r
-Code for pForth is maintained on GitHub at:\r
-  https://github.com/philburk/pforth\r
- \r
-Documentation for pForth at:\r
-  http://www.softsynth.com/pforth/\r
-\r
-For technical support please use the pForth forum at:\r
-  http://groups.google.com/group/pforthdev\r
-  \r
--- LEGAL NOTICE -----------------------------------------\r
-\r
-The pForth software code is dedicated to the public domain,\r
-and any third party may reproduce, distribute and modify\r
-the pForth software code or any derivative works thereof\r
-without any compensation or license.  The pForth software\r
-code is provided on an "as is" basis without any warranty\r
-of any kind, including, without limitation, the implied\r
-warranties of merchantability and fitness for a particular\r
-purpose and their equivalents under the laws of any jurisdiction.\r
-\r
--- Contents of SDK --------------------------------------\r
-\r
-       build - tools for building pForth on various platforms\r
-       build/win32/vs2005 - Visual Studio 2005 Project and Solution\r
-       build/unix - Makefile for unix\r
-       \r
-       csrc - pForth kernel in ANSI 'C'\r
-       csrc/pf_main.c - main() application for a standalone Forth\r
-       csrc/stdio - I/O code using basic stdio for generic platforms\r
-       csrc/posix - I/O code for Posix platform\r
-       csrc/win32 - I/O code for basic WIN32 platform\r
-       csrc/win32_console - I/O code for WIN32 console that supports command line history\r
-       \r
-       fth - Forth code\r
-       fth/util - utility functions\r
-\r
--- How to build pForth ------------------------------------\r
-\r
-See pForth reference manual at:\r
-\r
-  http://www.softsynth.com/pforth/pf_ref.php\r
-  \r
--- How to run pForth ------------------------------------\r
-\r
-Once you have compiled and built the dictionary, just enter:\r
-     pforth\r
-\r
-To compile source code files use:    INCLUDE filename\r
-\r
-To create a custom dictionary enter in pForth:\r
-       c" newfilename.dic" SAVE-FORTH\r
-The name must end in ".dic".\r
-\r
-To run PForth with the new dictionary enter in the shell:\r
-       pforth -dnewfilename.dic\r
-\r
-To run PForth and automatically include a forth file:\r
-       pforth myprogram.fth\r
-\r
--- How to Test PForth ------------------------------------\r
-\r
-You can test the Forth without loading a dictionary\r
-which might be necessary if the dictionary can't be built.\r
-\r
-Enter:   pforth -i\r
-In pForth, enter:    3 4 + .\r
-In pForth, enter:    loadsys\r
-In pForth, enter:    10  0  do i . loop\r
-\r
-PForth comes with a small test suite.  To test the Core words,\r
-you can use the coretest developed by John Hayes.\r
-\r
-Enter:  pforth\r
-Enter:  include tester.fth\r
-Enter:  include coretest.fth\r
-\r
-To run the other tests, enter:\r
-\r
-       pforth t_corex.fth\r
-       pforth t_strings.fth\r
-       pforth t_locals.fth\r
-       pforth t_alloc.fth\r
-       \r
-They will report the number of tests that pass or fail.\r
+README for pForth - a Portable ANS-like Forth written in ANSI 'C'
+
+by Phil Burk
+with Larry Polansky, David Rosenboom and Darren Gibbs.
+Support for 64-bit cells by Aleksej Saushev.
+
+Last updated: December 23, 2014 V27
+
+Code for pForth is maintained on GitHub at:
+  https://github.com/philburk/pforth
+ 
+Documentation for pForth at:
+  http://www.softsynth.com/pforth/
+
+For technical support please use the pForth forum at:
+  http://groups.google.com/group/pforthdev
+  
+-- LEGAL NOTICE -----------------------------------------
+
+The pForth software code is dedicated to the public domain,
+and any third party may reproduce, distribute and modify
+the pForth software code or any derivative works thereof
+without any compensation or license.  The pForth software
+code is provided on an "as is" basis without any 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.
+
+-- Contents of SDK --------------------------------------
+
+    build - tools for building pForth on various platforms
+    build/win32/vs2005 - Visual Studio 2005 Project and Solution
+    build/unix - Makefile for unix
+    
+    csrc - pForth kernel in ANSI 'C'
+    csrc/pf_main.c - main() application for a standalone Forth
+    csrc/stdio - I/O code using basic stdio for generic platforms
+    csrc/posix - I/O code for Posix platform
+    csrc/win32 - I/O code for basic WIN32 platform
+    csrc/win32_console - I/O code for WIN32 console that supports command line history
+    
+    fth - Forth code
+    fth/util - utility functions
+
+-- How to build pForth ------------------------------------
+
+See pForth reference manual at:
+
+  http://www.softsynth.com/pforth/pf_ref.php
+  
+-- How to run pForth ------------------------------------
+
+Once you have compiled and built the dictionary, just enter:
+     pforth
+
+To compile source code files use:    INCLUDE filename
+
+To create a custom dictionary enter in pForth:
+    c" newfilename.dic" SAVE-FORTH
+The name must end in ".dic".
+
+To run PForth with the new dictionary enter in the shell:
+    pforth -dnewfilename.dic
+
+To run PForth and automatically include a forth file:
+    pforth myprogram.fth
+
+-- How to Test PForth ------------------------------------
+
+You can test the Forth without loading a dictionary
+which might be necessary if the dictionary can't be built.
+
+Enter:   pforth -i
+In pForth, enter:    3 4 + .
+In pForth, enter:    loadsys
+In pForth, enter:    10  0  do i . loop
+
+PForth comes with a small test suite.  To test the Core words,
+you can use the coretest developed by John Hayes.
+
+Enter:  pforth
+Enter:  include tester.fth
+Enter:  include coretest.fth
+
+To run the other tests, enter:
+
+    pforth t_corex.fth
+    pforth t_strings.fth
+    pforth t_locals.fth
+    pforth t_alloc.fth
+    
+They will report the number of tests that pass or fail.

diff --git a/releases.txt b/releases.txt
index 5c2e189..c611579 100644 (file)
--- a/releases.txt
+++ b/releases.txt
@@ -1,276 +1,276 @@
-Release History for pForth - a Portable ANS-like Forth written in ANSI 'C'\r
-\r
-Documentation for pForth at http://www.softsynth.com/pforth/\r
-\r
-V28 - unreleased\r
-       - fixes for MinGW build\r
-\r
-V27 - 11/22/2010\r
-    - Fixed REPOSITION-FILE FILE-SIZE and FILE-POSITION.\r
-      They used to use single precision offset. Now use double as specified.\r
-    - Delete object directories in Makefile clean.\r
-    - Fixed "Issue 4: Filehandle remains locked upon INCLUDE error".\r
-      http://code.google.com/p/pforth/issues/detail?id=4&can=1\r
-    - Fixed scrambled HISTORY on 64-bit systems. Was using CELL+ but really needed 4 +.\r
-    - Fixed floating point input. Now accepts "1E" as 1.0. Was Issue #2.\r
-    - Fixed lots of warning and made code compatible with C89 and ANSI. Uses -pedantic.\r
-    - Use fseek and ftell on WIN32 instead of fseeko and ftello.\r
-    - Makefile is now more standard. Builds in same dir as Makefile. Uses CFLAGS etc.\r
-    - Add support for console IO with _WATCOMC_\r
-    - Internal CStringToForth and ForthStringToC now take a destination size for safety.\r
-    - Run units tests for CStringToForth and ForthStringToC if PF_UNIT_TESTS is defined.\r
-\r
-V26  5/20/2010\r
-    - 64-bit support for M* UM/MOD etc by Aleksej Saushev. Thanks Aleksej!\r
-    \r
-V25  5/19/2010\r
-    - Added 64-bit CELL support contributed by Aleksej Saushev. Thanks Aleksej!\r
-    - Added "-x c" to Makefile CCOPTS to prevent confusion with C++\r
-       - Allow space after -d command line option.\r
-       - Restore normal tty mode if pForth dictionary loading fails.\r
-        \r
-V24 2/20/09\r
-       - Fixed Posix IO on Mac. ?TERMINAL was always returning true.\r
-       - ACCCEPT now emits a space at end of line before output.\r
-       - Fixed RESIZE because it was returning the wrong address.\r
-\r
-V23 8/4/2008\r
-       - Removed -v option from mkdir in build/unix/Makefile. It was not supported on FreeBSD.\r
-         Thank you Alexsej Saushev for reporting this.\r
-       \r
-V23  7/20/2008\r
-    - Reorganized for Google Code project.\r
-    \r
-V22  (unreleased)\r
-    - Added command line history and cursor control words.\r
-       - Sped up UM* and M* by a factor of 3. Thanks to Steve Green for suggested algorithm.\r
-       - Modified ACCEPT so that a line at the end of a file that does NOT have a line\r
-           terminator will now be processed.\r
-       - Use _getch(), _putch(), and _kbhit() so that KEY, EMIT and ?TERMINAL will work on PC.\r
-       - Fixed  : foo { -- } 55 ;  - Was entering local frame but not exiting. Now prints error.\r
-    - Redefined MAKE_ID to protect it from 16 bit ints\r
-    - John Providenza says "If you split local variables onto 2 lines, PForth crashes." Fixed. Also allow \\r
-    - Fixed float evaluation in EVALUATE in "quit.fth".\r
-    - Flush register cache for ffColon and ffSemiColon to prevent stack warnings from ;\r
-\r
-V21 - 9/16/1998\r
-       - Fixed some compiler warnings.\r
-\r
-V20\r
-    - Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.\r
-      Thank you Michael Connor of Vancouver for reporting this bug.\r
-\r
-    - Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.".\r
-      Thank you Jim Rosenow of Minnesota for reporting this bug.\r
-       - Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS\r
-      Thank you Jim Rosenow of Minnesota for reporting this bug.\r
-\r
-       - "0.0 F~" now checks actual binary encoding of floats. Before this it used to just\r
-         compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE.\r
-\r
-       - Fixed definition of INPUT$ in tutorial.\r
-      Thank you Hampton Miller of California for reporting this bug.\r
-\r
-       - Added support for producing a target dictionary with a different\r
-         Endian-ness than the host CPU.  See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC.\r
-\r
-       - PForth kernel now comes up in a mode that uses BASE for numeric input when\r
-         started with "-i" option.  It used to always consider numeric input as HEX.\r
-         Initial BASE is decimal.  \r
-\r
-V19  4/1998\r
-\r
-       - Warn if local var name matches dictionary, : foo { count -- } ;\r
-       - TO -> and +-> now parse input stream. No longer use to-flag.\r
-       - TO -> and +-> now give error if used with non-immediate word.\r
-       - Added (FLITERAL) support to SEE.\r
-       - Aded TRACE facility for single step debugging of Forth words.\r
-       - Added stub for ?TERMINAL and KEY? for embedded systems.\r
-       - Added PF_NO_GLOBAL_INIT for no reliance on global initialization.\r
-       - Added PF_USER_FLOAT for customization of FP support.\r
-       - Added floating point to string conversion words (F.) (FS.) (FE.)\r
-           For example:   : F.   (F.)  TYPE  SPACE  ;\r
-       - Reversed order that values are placed on return stack in 2>R\r
-         so that it matches ANS standard.  2>R is now same as SWAP >R >R\r
-         Thank you Leo Wong for reporting this bug.\r
-\r
-       - Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls.\r
-\r
-       - FIXED memory leak in pfDoForth()\r
-\r
-V18\r
-       - Make FILL a 'C' primitive.\r
-       - optimized locals with (1_LOCAL@)\r
-       - optimized inner interpreter by 15%\r
-       - fix tester.fth failures\r
-       - Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined.\r
-       - Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition.\r
-       - Fixed saving and restoring of TIB when nesting include files.\r
-\r
-V17\r
-       - Fixed input of large floats.  0.7071234567 F.  used to fail.\r
-\r
-V16\r
-       * Define PF_USER_CUSTOM if you are defining your own custom\r
-         'C' glue routines.  This will ifndef the published example.\r
-       - Fixed warning in pf_cglue.c.\r
-       - Fixed SDAD in savedicd.fth.  It used to generate bogus 'C' code\r
-         if called when (BASE != 10), as in HEX mode.\r
-       - Fixed address comparisons in forget.fth and private.fth for\r
-         addresses above 0x80000000. Must be unsigned.\r
-       - Call FREEZE at end of system.fth to initialize rfence.\r
-       - Fixed 0.0 F. which used to leave 0.0 on FP stack.\r
-       - Added FPICK ( n -- ) ( i*f -- i*f f[n] )\r
-       - .S now prints hex numbers as unsigned.\r
-       - Fixed internal number to text conversion for unsigned nums.\r
-\r
-V15 - 2/15/97\r
-       * If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT\r
-         among other additions. See "pf_io.h".\r
-       * COMPARE now matches ANS STRING word set!\r
-       - Added PF_USER_INC1 and PF_USER_INC2 for optional includes\r
-         and host customization. See "pf_all.h".\r
-       - Fixed more warnings.\r
-       - Fixed >NAME and WORDS for systems with high "negative" addresses.\r
-       - Added WORDS.LIKE utility.  Enter:   WORDS.LIKE EMIT\r
-       - Added stack check after every word in high level interpreter.\r
-         Enter QUIT to enter high level interpreter which uses this feature.\r
-       - THROW will no longer crash if not using high level interpreter.\r
-       - Isolated all host dependencies into "pf_unix.h", "pf_win32.h",\r
-         "pf_mac.h", etc.  See "pf_all.h".\r
-       - Added tests for CORE EXT, STRINGS words sets.\r
-       - Added SEARCH\r
-       - Fixed WHILE and REPEAT for multiple WHILEs.\r
-       - Fixed .( ) for empty strings.\r
-       - Fixed FATAN2 which could not compile on some systems (Linux gcc).\r
-\r
-V14 - 12/23/96\r
-       * pforth command now requires -d before dictionary name.\r
-               Eg.   pforth -dcustom.dic test.fth\r
-       * PF_USER_* now need to be defined as include file names.\r
-       * PF_USER_CHARIO now requires different functions to be defined.\r
-               See "csrc/pf_io.h".\r
-       - Moved pfDoForth() from pf_main.c to pf_core.c to simplify\r
-         file with main().\r
-       - Fix build with PF_NO_INIT\r
-       - Makefile now has target for embedded dictionary, "gmake pfemb".\r
-\r
-V13 - 12/15/96\r
-       - Add "extern 'C' {" to pf_mem.h for C++\r
-       - Separate PF_STATIC_DIC from PF_NO_FILEIO so that we can use a static\r
-         dictionary but also have file I/O.\r
-       - Added PF_USER_FILEIO, PF_USER_CHARIO, PF_USER_CLIB.\r
-       - INCLUDE now aborts if file not found.\r
-       - Add +-> which allows you to add to a local variable, like +! .\r
-       - VALUE now works properly as a self fetching constant.\r
-       - Add CODE-SIZE and HEADERS-SIZE which lets you resize\r
-         dictionary saved using SAVE-FORTH.\r
-       - Added FILE?. Enter "FILE? THEN" to see what files THEN is defined in.\r
-       - Fixed bug in local variables that caused problems if compilation\r
-         aborted in a word with local variables.\r
-       - Added SEE which "disassembles" Forth words. See "see.fth".\r
-       - Added PRIVATE{ which can be used to hide low level support\r
-         words.  See "private.fth".\r
-       \r
-V12 - 12/1/96\r
-       - Advance pointers in pfCopyMemory() and pfSetMemory()\r
-         to fix PF_NO_CLIB build.\r
-       - Increase size of array for PF_NO_MALLOC\r
-       - Eliminate many warnings involving type casts and (const char *)\r
-       - Fix error recovery in dictionary creation.\r
-       - Conditionally eliminate some include files for embedded builds.\r
-       - Cleanup some test files.\r
-\r
-V11 - 11/14/96\r
-       - Added support for AUTO.INIT and AUTO.TERM.  These are called\r
-         automagically when the Forth starts and quits.\r
-       - Change all int to int32.\r
-       - Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH\r
-         to fix hang when zero local variables.\r
-       - Align long word members in :STRUCT to avoid bus errors.\r
-       \r
-V10 - 3/21/96\r
-       - Close nested source files when INCLUDE aborts.\r
-       - Add PF_NO_CLIB option to reduce OS dependencies.\r
-       - Add CREATE-FILE, fix R/W access mode for OPEN-FILE.\r
-       - Use PF_FLOAT instead of FLOAT to avoid DOS problem.\r
-       - Add PF_HOST_DOS for compilation control.\r
-       - Shorten all long file names to fit in the 8.3 format\r
-         required by some primitive operating systems. My\r
-         apologies to those with modern computers who suffer\r
-         as a result.  ;-)\r
-       \r
-V9 - 10/13/95\r
-       - Cleaned up and documented for alpha release.\r
-       - Added EXISTS?\r
-       - compile floats.fth if F* exists\r
-       - got PF_NO_SHELL working\r
-       - added TURNKEY to build headerless dictionary apps\r
-       - improved release script and rlsMakefile\r
-       - added FS@ and FS! for FLPT structure members\r
-\r
-V8 - 5/1/95\r
-       - Report line number and line dump when INCLUDE aborts\r
-       - Abort if stack depth changes in colon definition. Helps\r
-         detect unbalanced conditionals (IF without THEN).\r
-       - Print bytes added by include.  Helps determine current file.\r
-       - Added RETURN-CODE which is returned to caller, eg. UNIX shell.\r
-       - Changed Header and Code sizes to 60000 and 150000\r
-       - Added check for overflowing dictionary when creating secondaries.\r
-\r
-V8 - 5/1/95\r
-       - Report line number and line dump when INCLUDE aborts\r
-       - Abort if stack depth changes in colon definition. Helps\r
-         detect unbalanced conditionals (IF without THEN).\r
-       - Print bytes added by include.  Helps determine current file.\r
-       - Added RETURN-CODE which is returned to caller, eg. UNIX shell.\r
-       - Changed Header and Code sizes to 60000 and 150000\r
-       - Added check for overflowing dictionary when creating secondaries.\r
-       \r
-V7 - 4/12/95\r
-       - Converted to 3DO Teamware environment\r
-       - Added conditional compiler [IF] [ELSE] [THEN], use like #if\r
-       - Fixed W->S B->S for positive values\r
-       - Fixed ALLOCATE FREE validation.  Was failing on some 'C' compilers.\r
-       - Added FILE-SIZE\r
-       - Fixed ERASE, now fills with zero instead of BL\r
-       \r
-V6 - 3/16/95\r
-       - Added floating point\r
-       - Changed NUMBER? to return a numeric type\r
-       - Support double number entry, eg.   234.  -> 234 0\r
-\r
-V5 - 3/9/95\r
-       - Added pfReportError()\r
-       - Fixed problem with NumPrimitives growing and breaking dictionaries\r
-       - Reduced size of saved dictionaries, 198K -> 28K in one instance\r
-       - Funnel all terminal I/O through ioKey() and ioEmit()\r
-       - Removed dependencies on printf() except for debugging\r
-\r
-V4 - 3/6/95\r
-       - Added smart conditionals to allow IF THEN DO LOOP etc.\r
-         outside colon definitions.\r
-       - Fixed RSHIFT, made logical.\r
-       - Added ARSHIFT for arithmetic shift.\r
-       - Added proper M*\r
-       - Added <> U> U<\r
-       - Added FM/MOD SM/REM /MOD MOD */ */MOD\r
-       - Added +LOOP EVALUATE UNLOOP EXIT\r
-       - Everything passes "coretest.fth" except UM/MOD FIND and WORD\r
-       \r
-V3 - 3/1/95\r
-       - Added support for embedded systems: PF_NO_FILEIO\r
-       and PF_NO_MALLOC.\r
-       - Fixed bug in dictionary loader that treated HERE as name relative.\r
-       \r
-V2 - 8/94\r
-       - made improvements necessary for use with M2 Verilog testing\r
-\r
-V1 - 5/94\r
-       - built pForth from various Forths including HMSL\r
-\r
-----------------------------------------------------------\r
-       \r
-\r
-Enjoy,\r
-Phil Burk\r
+Release History for pForth - a Portable ANS-like Forth written in ANSI 'C'
+
+Documentation for pForth at http://www.softsynth.com/pforth/
+
+V28 - unreleased
+    - fixes for MinGW build
+
+V27 - 11/22/2010
+    - Fixed REPOSITION-FILE FILE-SIZE and FILE-POSITION.
+      They used to use single precision offset. Now use double as specified.
+    - Delete object directories in Makefile clean.
+    - Fixed "Issue 4: Filehandle remains locked upon INCLUDE error".
+      http://code.google.com/p/pforth/issues/detail?id=4&can=1
+    - Fixed scrambled HISTORY on 64-bit systems. Was using CELL+ but really needed 4 +.
+    - Fixed floating point input. Now accepts "1E" as 1.0. Was Issue #2.
+    - Fixed lots of warning and made code compatible with C89 and ANSI. Uses -pedantic.
+    - Use fseek and ftell on WIN32 instead of fseeko and ftello.
+    - Makefile is now more standard. Builds in same dir as Makefile. Uses CFLAGS etc.
+    - Add support for console IO with _WATCOMC_
+    - Internal CStringToForth and ForthStringToC now take a destination size for safety.
+    - Run units tests for CStringToForth and ForthStringToC if PF_UNIT_TESTS is defined.
+
+V26  5/20/2010
+    - 64-bit support for M* UM/MOD etc by Aleksej Saushev. Thanks Aleksej!
+    
+V25  5/19/2010
+    - Added 64-bit CELL support contributed by Aleksej Saushev. Thanks Aleksej!
+    - Added "-x c" to Makefile CCOPTS to prevent confusion with C++
+    - Allow space after -d command line option.
+    - Restore normal tty mode if pForth dictionary loading fails.
+     
+V24 2/20/09
+    - Fixed Posix IO on Mac. ?TERMINAL was always returning true.
+    - ACCCEPT now emits a space at end of line before output.
+    - Fixed RESIZE because it was returning the wrong address.
+
+V23 8/4/2008
+    - Removed -v option from mkdir in build/unix/Makefile. It was not supported on FreeBSD.
+      Thank you Alexsej Saushev for reporting this.
+    
+V23  7/20/2008
+    - Reorganized for Google Code project.
+    
+V22  (unreleased)
+    - Added command line history and cursor control words.
+    - Sped up UM* and M* by a factor of 3. Thanks to Steve Green for suggested algorithm.
+    - Modified ACCEPT so that a line at the end of a file that does NOT have a line
+        terminator will now be processed.
+    - Use _getch(), _putch(), and _kbhit() so that KEY, EMIT and ?TERMINAL will work on PC.
+    - Fixed  : foo { -- } 55 ;  - Was entering local frame but not exiting. Now prints error.
+    - Redefined MAKE_ID to protect it from 16 bit ints
+    - John Providenza says "If you split local variables onto 2 lines, PForth crashes." Fixed. Also allow \
+    - Fixed float evaluation in EVALUATE in "quit.fth".
+    - Flush register cache for ffColon and ffSemiColon to prevent stack warnings from ;
+
+V21 - 9/16/1998
+    - Fixed some compiler warnings.
+
+V20
+    - Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.
+      Thank you Michael Connor of Vancouver for reporting this bug.
+
+    - Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.".
+      Thank you Jim Rosenow of Minnesota for reporting this bug.
+    - Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS
+      Thank you Jim Rosenow of Minnesota for reporting this bug.
+
+    - "0.0 F~" now checks actual binary encoding of floats. Before this it used to just
+      compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE.
+
+    - Fixed definition of INPUT$ in tutorial.
+      Thank you Hampton Miller of California for reporting this bug.
+
+    - Added support for producing a target dictionary with a different
+      Endian-ness than the host CPU.  See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC.
+
+    - PForth kernel now comes up in a mode that uses BASE for numeric input when
+      started with "-i" option.  It used to always consider numeric input as HEX.
+      Initial BASE is decimal.  
+
+V19  4/1998
+
+    - Warn if local var name matches dictionary, : foo { count -- } ;
+    - TO -> and +-> now parse input stream. No longer use to-flag.
+    - TO -> and +-> now give error if used with non-immediate word.
+    - Added (FLITERAL) support to SEE.
+    - Aded TRACE facility for single step debugging of Forth words.
+    - Added stub for ?TERMINAL and KEY? for embedded systems.
+    - Added PF_NO_GLOBAL_INIT for no reliance on global initialization.
+    - Added PF_USER_FLOAT for customization of FP support.
+    - Added floating point to string conversion words (F.) (FS.) (FE.)
+        For example:   : F.   (F.)  TYPE  SPACE  ;
+    - Reversed order that values are placed on return stack in 2>R
+      so that it matches ANS standard.  2>R is now same as SWAP >R >R
+      Thank you Leo Wong for reporting this bug.
+
+    - Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls.
+
+    - FIXED memory leak in pfDoForth()
+
+V18
+    - Make FILL a 'C' primitive.
+    - optimized locals with (1_LOCAL@)
+    - optimized inner interpreter by 15%
+    - fix tester.fth failures
+    - Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined.
+    - Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition.
+    - Fixed saving and restoring of TIB when nesting include files.
+
+V17
+    - Fixed input of large floats.  0.7071234567 F.  used to fail.
+
+V16
+    * Define PF_USER_CUSTOM if you are defining your own custom
+      'C' glue routines.  This will ifndef the published example.
+    - Fixed warning in pf_cglue.c.
+    - Fixed SDAD in savedicd.fth.  It used to generate bogus 'C' code
+      if called when (BASE != 10), as in HEX mode.
+    - Fixed address comparisons in forget.fth and private.fth for
+      addresses above 0x80000000. Must be unsigned.
+    - Call FREEZE at end of system.fth to initialize rfence.
+    - Fixed 0.0 F. which used to leave 0.0 on FP stack.
+    - Added FPICK ( n -- ) ( i*f -- i*f f[n] )
+    - .S now prints hex numbers as unsigned.
+    - Fixed internal number to text conversion for unsigned nums.
+
+V15 - 2/15/97
+    * If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT
+      among other additions. See "pf_io.h".
+    * COMPARE now matches ANS STRING word set!
+    - Added PF_USER_INC1 and PF_USER_INC2 for optional includes
+      and host customization. See "pf_all.h".
+    - Fixed more warnings.
+    - Fixed >NAME and WORDS for systems with high "negative" addresses.
+    - Added WORDS.LIKE utility.  Enter:   WORDS.LIKE EMIT
+    - Added stack check after every word in high level interpreter.
+      Enter QUIT to enter high level interpreter which uses this feature.
+    - THROW will no longer crash if not using high level interpreter.
+    - Isolated all host dependencies into "pf_unix.h", "pf_win32.h",
+      "pf_mac.h", etc.  See "pf_all.h".
+    - Added tests for CORE EXT, STRINGS words sets.
+    - Added SEARCH
+    - Fixed WHILE and REPEAT for multiple WHILEs.
+    - Fixed .( ) for empty strings.
+    - Fixed FATAN2 which could not compile on some systems (Linux gcc).
+
+V14 - 12/23/96
+    * pforth command now requires -d before dictionary name.
+            Eg.   pforth -dcustom.dic test.fth
+    * PF_USER_* now need to be defined as include file names.
+    * PF_USER_CHARIO now requires different functions to be defined.
+        See "csrc/pf_io.h".
+    - Moved pfDoForth() from pf_main.c to pf_core.c to simplify
+      file with main().
+    - Fix build with PF_NO_INIT
+    - Makefile now has target for embedded dictionary, "gmake pfemb".
+
+V13 - 12/15/96
+    - Add "extern 'C' {" to pf_mem.h for C++
+    - Separate PF_STATIC_DIC from PF_NO_FILEIO so that we can use a static
+      dictionary but also have file I/O.
+    - Added PF_USER_FILEIO, PF_USER_CHARIO, PF_USER_CLIB.
+    - INCLUDE now aborts if file not found.
+    - Add +-> which allows you to add to a local variable, like +! .
+    - VALUE now works properly as a self fetching constant.
+    - Add CODE-SIZE and HEADERS-SIZE which lets you resize
+      dictionary saved using SAVE-FORTH.
+    - Added FILE?. Enter "FILE? THEN" to see what files THEN is defined in.
+    - Fixed bug in local variables that caused problems if compilation
+      aborted in a word with local variables.
+    - Added SEE which "disassembles" Forth words. See "see.fth".
+    - Added PRIVATE{ which can be used to hide low level support
+      words.  See "private.fth".
+    
+V12 - 12/1/96
+    - Advance pointers in pfCopyMemory() and pfSetMemory()
+      to fix PF_NO_CLIB build.
+    - Increase size of array for PF_NO_MALLOC
+    - Eliminate many warnings involving type casts and (const char *)
+    - Fix error recovery in dictionary creation.
+    - Conditionally eliminate some include files for embedded builds.
+    - Cleanup some test files.
+
+V11 - 11/14/96
+    - Added support for AUTO.INIT and AUTO.TERM.  These are called
+      automagically when the Forth starts and quits.
+    - Change all int to int32.
+    - Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH
+      to fix hang when zero local variables.
+    - Align long word members in :STRUCT to avoid bus errors.
+    
+V10 - 3/21/96
+    - Close nested source files when INCLUDE aborts.
+    - Add PF_NO_CLIB option to reduce OS dependencies.
+    - Add CREATE-FILE, fix R/W access mode for OPEN-FILE.
+    - Use PF_FLOAT instead of FLOAT to avoid DOS problem.
+    - Add PF_HOST_DOS for compilation control.
+    - Shorten all long file names to fit in the 8.3 format
+      required by some primitive operating systems. My
+      apologies to those with modern computers who suffer
+      as a result.  ;-)
+    
+V9 - 10/13/95
+    - Cleaned up and documented for alpha release.
+    - Added EXISTS?
+    - compile floats.fth if F* exists
+    - got PF_NO_SHELL working
+    - added TURNKEY to build headerless dictionary apps
+    - improved release script and rlsMakefile
+    - added FS@ and FS! for FLPT structure members
+
+V8 - 5/1/95
+    - Report line number and line dump when INCLUDE aborts
+    - Abort if stack depth changes in colon definition. Helps
+      detect unbalanced conditionals (IF without THEN).
+    - Print bytes added by include.  Helps determine current file.
+    - Added RETURN-CODE which is returned to caller, eg. UNIX shell.
+    - Changed Header and Code sizes to 60000 and 150000
+    - Added check for overflowing dictionary when creating secondaries.
+
+V8 - 5/1/95
+    - Report line number and line dump when INCLUDE aborts
+    - Abort if stack depth changes in colon definition. Helps
+      detect unbalanced conditionals (IF without THEN).
+    - Print bytes added by include.  Helps determine current file.
+    - Added RETURN-CODE which is returned to caller, eg. UNIX shell.
+    - Changed Header and Code sizes to 60000 and 150000
+    - Added check for overflowing dictionary when creating secondaries.
+    
+V7 - 4/12/95
+    - Converted to 3DO Teamware environment
+    - Added conditional compiler [IF] [ELSE] [THEN], use like #if
+    - Fixed W->S B->S for positive values
+    - Fixed ALLOCATE FREE validation.  Was failing on some 'C' compilers.
+    - Added FILE-SIZE
+    - Fixed ERASE, now fills with zero instead of BL
+    
+V6 - 3/16/95
+    - Added floating point
+    - Changed NUMBER? to return a numeric type
+    - Support double number entry, eg.   234.  -> 234 0
+
+V5 - 3/9/95
+    - Added pfReportError()
+    - Fixed problem with NumPrimitives growing and breaking dictionaries
+    - Reduced size of saved dictionaries, 198K -> 28K in one instance
+    - Funnel all terminal I/O through ioKey() and ioEmit()
+    - Removed dependencies on printf() except for debugging
+
+V4 - 3/6/95
+    - Added smart conditionals to allow IF THEN DO LOOP etc.
+      outside colon definitions.
+    - Fixed RSHIFT, made logical.
+    - Added ARSHIFT for arithmetic shift.
+    - Added proper M*
+    - Added <> U> U<
+    - Added FM/MOD SM/REM /MOD MOD */ */MOD
+    - Added +LOOP EVALUATE UNLOOP EXIT
+    - Everything passes "coretest.fth" except UM/MOD FIND and WORD
+    
+V3 - 3/1/95
+    - Added support for embedded systems: PF_NO_FILEIO
+    and PF_NO_MALLOC.
+    - Fixed bug in dictionary loader that treated HERE as name relative.
+    
+V2 - 8/94
+    - made improvements necessary for use with M2 Verilog testing
+
+V1 - 5/94
+    - built pForth from various Forths including HMSL
+
+----------------------------------------------------------
+    
+
+Enjoy,
+Phil Burk