Convert tabs to spaces.
Remove trailing whitespaces.
Convert EOL to LF.
No real code changes.
-/* @(#) 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 */
+
-/* @(#) 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
-/* @(#) 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 */
-/* @(#) 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 );
+}
-/* @(#) 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 */
-/* @(#) 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
-/* @(#) 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 */
-/* @(#) 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
-/* @(#) 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 */
-/* @(#) 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 */
+
-/* @(#) 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 */
-/* @(#) 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;
+}
-/* @(#) 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
+
-/* @(#) 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 */
-/* $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
-/* @(#) 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 */
+
+
-/***************************************************************\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 */
-/* @(#) 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 */
-/* @(#) 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;
+}
+
-/* @(#) 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 */
-/* @(#) 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
-/* @(#) 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 */
-/* @(#) 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 */
-/* @(#) 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 */
-/* @(#) 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];
+}
-/* @(#) 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 */
-/* @(#) 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
-/* @(#) 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;
+}
-/* @(#) 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 */
-/* @(#) 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 */
+
-/* @(#) 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
-/* @(#) 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 */
-/* $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);
+ }
+}
-/* $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 )
+{
+}
+
-/* $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
-/* $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
-\ @(#) 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
-\ @(#) 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
-\ @(#) 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]
-\ @(#) 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
+
-\ @(#) 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
-\ 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 }
+
+
-\ @(#) 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
+;
+
-\ @(#) 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]
-\ @(#) 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
+;
-\ 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]
-\ 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
-\ @(#) 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
-\ @(#) $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
+;
-\ @(#) 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
+;
-\ @(#) 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
+;
-\ @(#) 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
+;
-\ @(#) 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
+;
+
-\ @(#) 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
+;
-\ @(#) 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 !
+;
-\ @(#) 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
-\ @(#) 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]
-\ #! /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
+;
-\ @(#) 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
-\ @(#) 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
+;
+
+\ -----------------------------------------------
-: 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 ;
-\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
-\ @(#) 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
+
-\ 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
+;
-\ @(#) 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
+
-\ @(#) 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
+
-\ 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
-\ 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
-\ 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.
-\ 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
+;
-\ 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
-\ 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!
+;
-\ @(#) 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
+
-\ 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
-\ @(#) 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
-\ @(#) 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
+;
-\ 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]
-\ 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 ;
+
-\ @(#) 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]
-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
+
-\ @(#) 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
+
-\ @(#) 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]
+
-\ 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 .
-\ @(#) 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
-\ @(#) 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
+;
-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.
-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