From: Phil Burk Date: Wed, 27 Apr 2016 15:51:38 +0000 (-0700) Subject: Fix white spaces. X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/8e9db35f299d8f606ba003d3cd8fa9e2c868c880 Fix white spaces. Convert tabs to spaces. Remove trailing whitespaces. Convert EOL to LF. No real code changes. --- diff --git a/csrc/pf_all.h b/csrc/pf_all.h index 560b287..8d3ff6f 100644 --- a/csrc/pf_all.h +++ b/csrc/pf_all.h @@ -1,67 +1,67 @@ -/* @(#) 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_all.h 98/01/26 1.2 */ + +#ifndef _pf_all_h +#define _pf_all_h + +/*************************************************************** +** Include all files needed for PForth +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 940521 PLB Creation. +** +***************************************************************/ + +#ifdef PF_EMBEDDED + #define PF_NO_INIT + #define PF_NO_STDIO + #define PF_NO_MALLOC + #define PF_NO_CLIB + #define PF_NO_FILEIO +#endif + +/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */ +#ifdef __MWERKS__ + #define PF_SUPPORT_FP (1) +#endif + +#ifdef WIN32 + #define PF_USER_INC2 "pf_win32.h" +#endif + +#if defined(PF_USER_INC1) + #include PF_USER_INC1 +#else + #include "pf_inc1.h" +#endif + +#include "pforth.h" +#include "pf_types.h" +#include "pf_io.h" +#include "pf_guts.h" +#include "pf_text.h" +#include "pfcompil.h" +#include "pf_clib.h" +#include "pf_words.h" +#include "pf_save.h" +#include "pf_mem.h" +#include "pf_cglue.h" +#include "pf_core.h" + +#ifdef PF_USER_INC2 +/* This could be used to undef and redefine macros. */ + #include PF_USER_INC2 +#endif + +#endif /* _pf_all_h */ + diff --git a/csrc/pf_cglue.c b/csrc/pf_cglue.c index 0ec1e70..d70851e 100644 --- a/csrc/pf_cglue.c +++ b/csrc/pf_cglue.c @@ -1,100 +1,100 @@ -/* @(#) 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.c 98/02/11 1.4 */ +/*************************************************************** +** 'C' Glue support for Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include "pf_all.h" + +extern CFunc0 CustomFunctionTable[]; + +/***************************************************************/ +cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams ) +{ + cell_t P1, P2, P3, P4, P5; + cell_t Result = 0; + CFunc0 CF; + +DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n", + Index, ReturnMode, NumParams )); + + CF = CustomFunctionTable[Index]; + + switch( NumParams ) + { + case 0: + Result = ((CFunc0) CF) ( ); + break; + case 1: + P1 = POP_DATA_STACK; + Result = ((CFunc1) CF) ( P1 ); + break; + case 2: + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc2) CF) ( P1, P2 ); + break; + case 3: + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc3) CF) ( P1, P2, P3 ); + break; + case 4: + P4 = POP_DATA_STACK; + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc4) CF) ( P1, P2, P3, P4 ); + break; + case 5: + P5 = POP_DATA_STACK; + P4 = POP_DATA_STACK; + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 ); + break; + default: + pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS); + EXIT(1); + } + +/* Push result on Forth stack if requested. */ + if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result ); + + return Result; +} + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) +/***************************************************************/ +Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams ) +{ + ucell_t Packed; + char FName[40]; + + CStringToForth( FName, CName, sizeof(FName) ); + Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) | + (ReturnMode << 31); + DBUG(("Packed = 0x%8x\n", Packed)); + + ffCreateSecondaryHeader( FName ); + CODE_COMMA( ID_CALL_C ); + CODE_COMMA(Packed); + ffFinishSecondary(); + + return 0; +} +#endif diff --git a/csrc/pf_cglue.h b/csrc/pf_cglue.h index c3ddc87..4f82da1 100644 --- a/csrc/pf_cglue.h +++ b/csrc/pf_cglue.h @@ -1,45 +1,45 @@ -/* @(#) 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_cglue.h 96/12/18 1.7 */ +#ifndef _pf_c_glue_h +#define _pf_c_glue_h + +/*************************************************************** +** Include file for PForth 'C' Glue support +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +typedef cell_t (*CFunc0)( void ); +typedef cell_t (*CFunc1)( cell_t P1 ); +typedef cell_t (*CFunc2)( cell_t P1, cell_t P2 ); +typedef cell_t (*CFunc3)( cell_t P1, cell_t P2, cell_t P3 ); +typedef cell_t (*CFunc4)( cell_t P1, cell_t P2, cell_t P3, cell_t P4 ); +typedef cell_t (*CFunc5)( cell_t P1, cell_t P2, cell_t P3, cell_t P4, cell_t P5 ); + +#ifdef __cplusplus +extern "C" { +#endif + +Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams ); +Err CompileCustomFunctions( void ); +Err LoadCustomFunctionTable( void ); +cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams ); + +#ifdef __cplusplus +} +#endif + +#define C_RETURNS_VOID (0) +#define C_RETURNS_VALUE (1) + +#endif /* _pf_c_glue_h */ diff --git a/csrc/pf_clib.c b/csrc/pf_clib.c index 0299c3b..d7212f0 100644 --- a/csrc/pf_clib.c +++ b/csrc/pf_clib.c @@ -1,64 +1,64 @@ -/* @(#) 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.c 96/12/18 1.12 */ +/*************************************************************** +** Duplicate functions from stdlib for PForth based on 'C' +** +** This code duplicates some of the code in the 'C' lib +** because it reduces the dependency on foreign libraries +** for monitor mode where no OS is available. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 961124 PLB Advance pointers in pfCopyMemory() and pfSetMemory() +***************************************************************/ + +#include "pf_all.h" + +#ifdef PF_NO_CLIB +/* Count chars until NUL. Replace strlen() */ +#define NUL ((char) 0) +cell_t pfCStringLength( const char *s ) +{ + cell_t len = 0; + while( *s++ != NUL ) len++; + return len; +} + +/* void *memset (void *s, cell_t c, size_t n); */ +void *pfSetMemory( void *s, cell_t c, cell_t n ) +{ + uint8_t *p = s, byt = (uint8_t) c; + while( (n--) > 0) *p++ = byt; + return s; +} + +/* void *memccpy (void *s1, const void *s2, cell_t c, size_t n); */ +void *pfCopyMemory( void *s1, const void *s2, cell_t n) +{ + uint8_t *p1 = s1; + const uint8_t *p2 = s2; + while( (n--) > 0) *p1++ = *p2++; + return s1; +} + +#endif /* PF_NO_CLIB */ + +char pfCharToUpper( char c ) +{ + return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c ); +} + +char pfCharToLower( char c ) +{ + return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c ); +} diff --git a/csrc/pf_clib.h b/csrc/pf_clib.h index da3dc5f..5cb5007 100644 --- a/csrc/pf_clib.h +++ b/csrc/pf_clib.h @@ -1,63 +1,63 @@ -/* @(#) 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_clib.h 96/12/18 1.10 */ +#ifndef _pf_clib_h +#define _pf_clib_h + +/*************************************************************** +** Include file for PForth tools +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_CLIB + + #ifdef __cplusplus + extern "C" { + #endif + + cell_t pfCStringLength( const char *s ); + void *pfSetMemory( void *s, cell_t c, cell_t n ); + void *pfCopyMemory( void *s1, const void *s2, cell_t n); + #define EXIT(n) {while(1);} + + #ifdef __cplusplus + } + #endif + +#else /* PF_NO_CLIB */ + + #ifdef PF_USER_CLIB + #include PF_USER_CLIB + #else +/* Use stdlib functions if available because they are probably faster. */ + #define pfCStringLength strlen + #define pfSetMemory memset + #define pfCopyMemory memcpy + #define EXIT(n) exit(n) + #endif /* PF_USER_CLIB */ + +#endif /* !PF_NO_CLIB */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */ +char pfCharToUpper( char c ); +char pfCharToLower( char c ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pf_clib_h */ diff --git a/csrc/pf_core.c b/csrc/pf_core.c index 00149f4..1736aa9 100644 --- a/csrc/pf_core.c +++ b/csrc/pf_core.c @@ -1,590 +1,590 @@ -/* @(#) 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.c 98/01/28 1.5 */ +/*************************************************************** +** Forth based on 'C' +** +** This file has the main entry points to the pForth library. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 940502 PLB Creation. +** 940505 PLB More macros. +** 940509 PLB Moved all stack handling into inner interpreter. +** Added Create, Colon, Semicolon, HNumberQ, etc. +** 940510 PLB Got inner interpreter working with secondaries. +** Added (LITERAL). Compiles colon definitions. +** 940511 PLB Added conditionals, LITERAL, CREATE DOES> +** 940512 PLB Added DO LOOP DEFER, fixed R> +** 940520 PLB Added INCLUDE +** 940521 PLB Added NUMBER? +** 940930 PLB Outer Interpreter now uses deferred NUMBER? +** 941005 PLB Added ANSI locals, LEAVE, modularised +** 950320 RDG Added underflow checking for FP stack +** 970702 PLB Added STACK_SAFETY to FP stack size. +***************************************************************/ + +#include "pf_all.h" + +/*************************************************************** +** Global Data +***************************************************************/ + +char gScratch[TIB_SIZE]; +pfTaskData_t *gCurrentTask = NULL; +pfDictionary_t *gCurrentDictionary; +cell_t gNumPrimitives; + +ExecToken gLocalCompiler_XT; /* custom compiler for local variables */ +ExecToken gNumberQ_XT; /* XT of NUMBER? */ +ExecToken gQuitP_XT; /* XT of (QUIT) */ +ExecToken gAcceptP_XT; /* XT of ACCEPT */ + +/* Depth of data stack when colon called. */ +cell_t gDepthAtColon; + +/* Global Forth variables. */ +cell_t gVarContext; /* Points to last name field. */ +cell_t gVarState; /* 1 if compiling. */ +cell_t gVarBase; /* Numeric Base. */ +cell_t gVarEcho; /* Echo input. */ +cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */ +cell_t gVarTraceStack; /* Dump Stack each time if true. */ +cell_t gVarTraceFlags; /* Enable various internal debug messages. */ +cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ +cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ + +/* data for INCLUDE that allows multiple nested files. */ +IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; +cell_t gIncludeIndex; + +static void pfResetForthTask( void ); +static void pfInit( void ); +static void pfTerm( void ); + +/* TODO move to pf_config.h header. */ +#define DEFAULT_RETURN_DEPTH (512) +#define DEFAULT_USER_DEPTH (512) +#define DEFAULT_HEADER_SIZE (120000) +#define DEFAULT_CODE_SIZE (300000) + +/* Initialize globals in a function to simplify loading on + * embedded systems which may not support initialization of data section. + */ +static void pfInit( void ) +{ +/* all zero */ + gCurrentTask = NULL; + gCurrentDictionary = NULL; + gNumPrimitives = 0; + gLocalCompiler_XT = 0; + gVarContext = (cell_t)NULL; /* Points to last name field. */ + gVarState = 0; /* 1 if compiling. */ + gVarEcho = 0; /* Echo input. */ + gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */ + gVarTraceFlags = 0; /* Enable various internal debug messages. */ + gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */ + gIncludeIndex = 0; + +/* non-zero */ + gVarBase = 10; /* Numeric Base. */ + gDepthAtColon = DEPTH_AT_COLON_INVALID; + gVarTraceStack = 1; + + pfInitMemoryAllocator(); + ioInit(); +} +static void pfTerm( void ) +{ + ioTerm(); +} + +/*************************************************************** +** Task Management +***************************************************************/ + +void pfDeleteTask( PForthTask task ) +{ + pfTaskData_t *cftd = (pfTaskData_t *)task; + FREE_VAR( cftd->td_ReturnLimit ); + FREE_VAR( cftd->td_StackLimit ); + pfFreeMem( cftd ); +} + +/* Allocate some extra cells to protect against mild stack underflows. */ +#define STACK_SAFETY (8) +PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth ) +{ + pfTaskData_t *cftd; + + cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) ); + if( !cftd ) goto nomem; + pfSetMemory( cftd, 0, sizeof( pfTaskData_t )); + +/* Allocate User Stack */ + cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * + (UserStackDepth + STACK_SAFETY))); + if( !cftd->td_StackLimit ) goto nomem; + cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth; + cftd->td_StackPtr = cftd->td_StackBase; + +/* Allocate Return Stack */ + cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) ); + if( !cftd->td_ReturnLimit ) goto nomem; + cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth; + cftd->td_ReturnPtr = cftd->td_ReturnBase; + +/* Allocate Float Stack */ +#ifdef PF_SUPPORT_FP +/* Allocate room for as many Floats as we do regular data. */ + cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) * + (UserStackDepth + STACK_SAFETY))); + if( !cftd->td_FloatStackLimit ) goto nomem; + cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth; + cftd->td_FloatStackPtr = cftd->td_FloatStackBase; +#endif + + cftd->td_InputStream = PF_STDIN; + + cftd->td_SourcePtr = &cftd->td_TIB[0]; + cftd->td_SourceNum = 0; + + return (PForthTask) cftd; + +nomem: + ERR("CreateTaskContext: insufficient memory.\n"); + if( cftd ) pfDeleteTask( (PForthTask) cftd ); + return NULL; +} + +/*************************************************************** +** Dictionary Management +***************************************************************/ + +cell_t pfExecIfDefined( const char *CString ) +{ + int result = 0; + if( NAME_BASE != (cell_t)NULL) + { + ExecToken XT; + if( ffFindC( CString, &XT ) ) + { + result = pfCatch( XT ); + } + } + return result; +} + +/*************************************************************** +** Delete a dictionary created by pfCreateDictionary() +*/ +void pfDeleteDictionary( PForthDictionary dictionary ) +{ + pfDictionary_t *dic = (pfDictionary_t *) dictionary; + if( !dic ) return; + + if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS ) + { + FREE_VAR( dic->dic_HeaderBaseUnaligned ); + FREE_VAR( dic->dic_CodeBaseUnaligned ); + } + pfFreeMem( dic ); +} + +/*************************************************************** +** Create a complete dictionary. +** The dictionary consists of two parts, the header with the names, +** and the code portion. +** Delete using pfDeleteDictionary(). +** Return pointer to dictionary management structure. +*/ +PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize ) +{ +/* Allocate memory for initial dictionary. */ + pfDictionary_t *dic; + + dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) ); + if( !dic ) goto nomem; + pfSetMemory( dic, 0, sizeof( pfDictionary_t )); + + dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS; + +/* Align dictionary segments to preserve alignment of floats across hosts. + * Thank you Helmut Proelss for pointing out that this needs to be cast + * to (ucell_t) on 16 bit systems. + */ +#define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10)) +#define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)) + +/* Allocate memory for header. */ + if( HeaderSize > 0 ) + { + dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_HeaderBaseUnaligned ) goto nomem; +/* Align header base. */ + dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned); + pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize); + dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize; + dic->dic_HeaderPtr = dic->dic_HeaderBase; + } + else + { + dic->dic_HeaderBase = 0; + } + +/* Allocate memory for code. */ + dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_CodeBaseUnaligned ) goto nomem; + dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned); + pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize); + + dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize; + dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES))); + + return (PForthDictionary) dic; +nomem: + pfDeleteDictionary( dic ); + return NULL; +} + +/*************************************************************** +** Used by Quit and other routines to restore system. +***************************************************************/ + +static void pfResetForthTask( void ) +{ +/* Go back to terminal input. */ + gCurrentTask->td_InputStream = PF_STDIN; + +/* Reset stacks. */ + gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase; + gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase; +#ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */ + gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase; +#endif + +/* Advance >IN to end of input. */ + gCurrentTask->td_IN = gCurrentTask->td_SourceNum; + gVarState = 0; +} + +/*************************************************************** +** Set current task context. +***************************************************************/ + +void pfSetCurrentTask( PForthTask task ) +{ + gCurrentTask = (pfTaskData_t *) task; +} + +/*************************************************************** +** Set Quiet Flag. +***************************************************************/ + +void pfSetQuiet( cell_t IfQuiet ) +{ + gVarQuiet = (cell_t) IfQuiet; +} + +/*************************************************************** +** Query message status. +***************************************************************/ + +cell_t pfQueryQuiet( void ) +{ + return gVarQuiet; +} + +/*************************************************************** +** Top level interpreter. +***************************************************************/ +ThrowCode pfQuit( void ) +{ + ThrowCode exception; + int go = 1; + + while(go) + { + exception = ffOuterInterpreterLoop(); + if( exception == 0 ) + { + exception = ffOK(); + } + + switch( exception ) + { + case 0: + break; + + case THROW_BYE: + go = 0; + break; + + case THROW_ABORT: + default: + ffDotS(); + pfReportThrow( exception ); + pfHandleIncludeError(); + pfResetForthTask(); + break; + } + } + + return gVarReturnCode; +} + +/*************************************************************** +** Include file based on 'C' name. +***************************************************************/ + +cell_t pfIncludeFile( const char *FileName ) +{ + FileStream *fid; + cell_t Result; + char buffer[32]; + cell_t numChars, len; + +/* Open file. */ + fid = sdOpenFile( FileName, "r" ); + if( fid == NULL ) + { + ERR("pfIncludeFile could not open "); + ERR(FileName); + EMIT_CR; + return -1; + } + +/* Create a dictionary word named ::::FileName for FILE? */ + pfCopyMemory( &buffer[0], "::::", 4); + len = (cell_t) pfCStringLength(FileName); + numChars = ( len > (32-4-1) ) ? (32-4-1) : len; + pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 ); + CreateDicEntryC( ID_NOOP, buffer, 0 ); + + Result = ffIncludeFile( fid ); /* Also close the file. */ + +/* Create a dictionary word named ;;;; for FILE? */ + CreateDicEntryC( ID_NOOP, ";;;;", 0 ); + + return Result; +} + +/*************************************************************** +** Output 'C' string message. +** Use sdTerminalOut which works before initializing gCurrentTask. +***************************************************************/ +void pfDebugMessage( const char *CString ) +{ +#if 0 + while( *CString ) + { + char c = *CString++; + if( c == '\n' ) + { + sdTerminalOut( 0x0D ); + sdTerminalOut( 0x0A ); + pfDebugMessage( "DBG: " ); + } + else + { + sdTerminalOut( c ); + } + } +#else + (void)CString; +#endif +} + +/*************************************************************** +** Print a decimal number to debug output. +*/ +void pfDebugPrintDecimalNumber( int n ) +{ + pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) ); +} + + +/*************************************************************** +** Output 'C' string message. +** This is provided to help avoid the use of printf() and other I/O +** which may not be present on a small embedded system. +** Uses ioType & ioEmit so requires that gCurrentTask has been initialized. +***************************************************************/ +void pfMessage( const char *CString ) +{ + ioType( CString, (cell_t) pfCStringLength(CString) ); +} + +/************************************************************************** +** Main entry point for pForth. +*/ +cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit ) +{ + pfTaskData_t *cftd; + pfDictionary_t *dic = NULL; + cell_t Result = 0; + ExecToken EntryPoint = 0; + +#ifdef PF_USER_INIT + Result = PF_USER_INIT; + if( Result < 0 ) goto error1; +#endif + + pfInit(); + +/* Allocate Task structure. */ + pfDebugMessage("pfDoForth: call pfCreateTask()\n"); + cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH ); + + if( cftd ) + { + pfSetCurrentTask( cftd ); + + if( !gVarQuiet ) + { + MSG( "PForth V"PFORTH_VERSION ); + if( IsHostLittleEndian() ) MSG("-LE"); + else MSG("-BE"); +#if PF_BIG_ENDIAN_DIC + MSG("/BE"); +#elif PF_LITTLE_ENDIAN_DIC + MSG("/LE"); +#endif + if (sizeof(cell_t) == 8) + { + MSG("/64"); + } + else if (sizeof(cell_t) == 4) + { + MSG("/32"); + } + + MSG( ", built "__DATE__" "__TIME__ ); + } + +/* Don't use MSG before task set. */ + if( SourceName ) + { + pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n"); + } + + +#ifdef PF_NO_GLOBAL_INIT + if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */ +#endif + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) + if( IfInit ) + { + pfDebugMessage("Build dictionary from scratch.\n"); + dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE ); + } + else +#else + TOUCH(IfInit); +#endif /* !PF_NO_INIT && !PF_NO_SHELL*/ + { + if( DicFileName ) + { + pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n"); + if( !gVarQuiet ) + { + EMIT_CR; + } + dic = pfLoadDictionary( DicFileName, &EntryPoint ); + } + else + { + if( !gVarQuiet ) + { + MSG(" (static)"); + EMIT_CR; + } + dic = pfLoadStaticDictionary(); + } + } + if( dic == NULL ) goto error2; + + if( !gVarQuiet ) + { + EMIT_CR; + } + + pfDebugMessage("pfDoForth: try AUTO.INIT\n"); + Result = pfExecIfDefined("AUTO.INIT"); + if( Result != 0 ) + { + MSG("Error in AUTO.INIT"); + goto error2; + } + + if( EntryPoint != 0 ) + { + Result = pfCatch( EntryPoint ); + } +#ifndef PF_NO_SHELL + else + { + if( SourceName == NULL ) + { + pfDebugMessage("pfDoForth: pfQuit\n"); + Result = pfQuit(); + } + else + { + if( !gVarQuiet ) + { + MSG("Including: "); + MSG(SourceName); + MSG("\n"); + } + Result = pfIncludeFile( SourceName ); + } + } +#endif /* PF_NO_SHELL */ + + /* Clean up after running Forth. */ + pfExecIfDefined("AUTO.TERM"); + pfDeleteDictionary( dic ); + pfDeleteTask( cftd ); + } + + pfTerm(); + +#ifdef PF_USER_TERM + PF_USER_TERM; +#endif + + return Result; + +error2: + MSG("pfDoForth: Error occured.\n"); + pfDeleteTask( cftd ); + /* Terminate so we restore normal shell tty mode. */ + pfTerm(); + +#ifdef PF_USER_INIT +error1: +#endif + + return -1; +} + + +#ifdef PF_UNIT_TEST +cell_t pfUnitTest( void ) +{ + cell_t numErrors = 0; + numErrors += pfUnitTestText(); + return numErrors; +} +#endif diff --git a/csrc/pf_core.h b/csrc/pf_core.h index 1279e8b..ffae934 100644 --- a/csrc/pf_core.h +++ b/csrc/pf_core.h @@ -1,38 +1,38 @@ -/* @(#) 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_core.h 98/01/26 1.3 */ +#ifndef _pf_core_h +#define _pf_core_h + +/*************************************************************** +** Include file for PForth 'C' Glue support +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void pfInitGlobals( void ); + +void pfDebugMessage( const char *CString ); +void pfDebugPrintDecimalNumber( int n ); + +cell_t pfUnitTestText( void ); + +#ifdef __cplusplus +} +#endif + + +#endif /* _pf_core_h */ diff --git a/csrc/pf_float.h b/csrc/pf_float.h index bc7128e..1e4439e 100644 --- a/csrc/pf_float.h +++ b/csrc/pf_float.h @@ -1,43 +1,43 @@ -/* @(#) 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_float.h 98/01/28 1.1 */ +#ifndef _pf_float_h +#define _pf_float_h + +/*************************************************************** +** Include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +typedef double PF_FLOAT; + +/* Define pForth specific math functions. */ + +#define fp_acos acos +#define fp_asin asin +#define fp_atan atan +#define fp_atan2 atan2 +#define fp_cos cos +#define fp_cosh cosh +#define fp_fabs fabs +#define fp_floor floor +#define fp_log log +#define fp_log10 log10 +#define fp_pow pow +#define fp_sin sin +#define fp_sinh sinh +#define fp_sqrt sqrt +#define fp_tan tan +#define fp_tanh tanh + +#endif diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h index 80df530..3667824 100644 --- a/csrc/pf_guts.h +++ b/csrc/pf_guts.h @@ -1,597 +1,597 @@ -/* @(#) 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=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_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=0)) + +#define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } } + +#define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) +#define DROP_DATA_STACK (gCurrentTask->td_StackPtr++) +#define POP_DATA_STACK (*gCurrentTask->td_StackPtr++) +#define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; } + +/* Force Quad alignment. */ +#define QUADUP(x) (((x)+3)&~3) + +#define MIN(a,b) ( ((a)<(b)) ? (a) : (b) ) +#define MAX(a,b) ( ((a)>(b)) ? (a) : (b) ) + + +#ifndef TOUCH + #define TOUCH(argument) ((void)argument) +#endif + +/*************************************************************** +** I/O related macros +***************************************************************/ + +#define EMIT(c) ioEmit(c) +#define EMIT_CR EMIT('\n'); + +#define MSG(cs) pfMessage(cs) +#define ERR(x) MSG(x) + +#define DBUG(x) /* PRT(x) */ +#define DBUGX(x) /* DBUG(x) */ + +#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; } +#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; } + +#define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); } + +#endif /* _pf_guts_h */ diff --git a/csrc/pf_host.h b/csrc/pf_host.h index 00e7dcb..c95b16f 100644 --- a/csrc/pf_host.h +++ b/csrc/pf_host.h @@ -1,24 +1,24 @@ -/* @(#) 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_host.h 96/12/18 1.12 */ +#ifndef _pf_system_h +#define _pf_system_h + +/*************************************************************** +** System Dependant Includes for PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +***************************************************************/ + +#endif /* _pf_system_h */ + diff --git a/csrc/pf_inc1.h b/csrc/pf_inc1.h index e391841..ba3f417 100644 --- a/csrc/pf_inc1.h +++ b/csrc/pf_inc1.h @@ -1,44 +1,44 @@ -/* @(#) 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 /* Needed for strlen(), memcpy(), and memset(). */ - #include /* Needed for exit(). */ -#endif - -#ifdef PF_NO_STDIO - #define NULL ((void *) 0) - #define EOF (-1) -#else - #include -#endif - -#ifdef PF_SUPPORT_FP - #include - - #ifndef PF_USER_FP - #include "pf_float.h" - #else - #include PF_USER_FP - #endif -#endif - -#endif /* _pf_embedded_h */ +/* @(#) 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 /* Needed for strlen(), memcpy(), and memset(). */ + #include /* Needed for exit(). */ +#endif + +#ifdef PF_NO_STDIO + #define NULL ((void *) 0) + #define EOF (-1) +#else + #include +#endif + +#ifdef PF_SUPPORT_FP + #include + + #ifndef PF_USER_FP + #include "pf_float.h" + #else + #include PF_USER_FP + #endif +#endif + +#endif /* _pf_embedded_h */ diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c index dc9c719..d616c22 100644 --- a/csrc/pf_inner.c +++ b/csrc/pf_inner.c @@ -1,1803 +1,1803 @@ -/* @(#) 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 - -#include "pf_all.h" - -#if defined(WIN32) && !defined(__MINGW32__) -#include -#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; itd_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> 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 -- n , fetch from local ) */ - TOS = *(LocalsPtr - TOS); - endcase; - -#define LOCAL_FETCH_N(num) \ - case ID_LOCAL_FETCH_##num: /* ( -- 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 -- , store n in local ) */ - *(LocalsPtr - TOS) = M_POP; - M_DROP; - endcase; - -#define LOCAL_STORE_N(num) \ - case ID_LOCAL_STORE_##num: /* ( n -- , 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 -- , 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; } 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_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 + +#include "pf_all.h" + +#if defined(WIN32) && !defined(__MINGW32__) +#include +#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; itd_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> 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 -- n , fetch from local ) */ + TOS = *(LocalsPtr - TOS); + endcase; + +#define LOCAL_FETCH_N(num) \ + case ID_LOCAL_FETCH_##num: /* ( -- 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 -- , store n in local ) */ + *(LocalsPtr - TOS) = M_POP; + M_DROP; + endcase; + +#define LOCAL_STORE_N(num) \ + case ID_LOCAL_STORE_##num: /* ( n -- , 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 -- , 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; } endcase; + +#ifndef PF_NO_SHELL + case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */ + { + cell_t NameSize, CodeSize, EntryPoint; + CodeSize = TOS; + NameSize = M_POP; + EntryPoint = M_POP; + ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) ); + TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize ); + } + endcase; +#endif + +/* Source Stack +** EVALUATE >IN SourceID=(-1) 1111 +** keyboard >IN SourceID=(0) 2222 +** file >IN lineNumber filePos SourceID=(fileID) +*/ + case ID_SAVE_INPUT: /* FIXME - finish */ + { + } + endcase; + + case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */ + PUSH_TOS; + TOS = (cell_t)STKPTR; + endcase; + + case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ + STKPTR = (cell_t *) TOS; + M_DROP; + endcase; + + case ID_STORE: /* ( n addr -- , write n to addr ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + WRITE_CELL_DIC((cell_t *)TOS,M_POP); + } + else + { + *((cell_t *)TOS) = M_POP; + } +#else + *((cell_t *)TOS) = M_POP; +#endif + M_DROP; + endcase; + + case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */ + Scratch = M_POP; /* cnt */ + Temp = M_POP; /* addr */ + TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr ); + M_PUSH((cell_t) CharPtr); + endcase; + +#ifndef PF_NO_SHELL + case ID_SEMICOLON: + SAVE_REGISTERS; + Scratch = ffSemiColon(); + LOAD_REGISTERS; + if( Scratch ) M_THROW( Scratch ); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */ + Scratch = M_POP; /* cnt */ + Temp = M_POP; /* addr */ + TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr ); + M_PUSH((cell_t) CharPtr); + endcase; + + case ID_SOURCE: /* ( -- c-addr num ) */ + PUSH_TOS; + M_PUSH( (cell_t) gCurrentTask->td_SourcePtr ); + TOS = (cell_t) gCurrentTask->td_SourceNum; + endcase; + + case ID_SOURCE_SET: /* ( c-addr num -- ) */ + gCurrentTask->td_SourcePtr = (char *) M_POP; + gCurrentTask->td_SourceNum = TOS; + M_DROP; + endcase; + + case ID_SOURCE_ID: + PUSH_TOS; + TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ; + endcase; + + case ID_SOURCE_ID_POP: + PUSH_TOS; + TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ; + endcase; + + case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */ + TOS = (cell_t)ffConvertSourceIDToStream( TOS ); + Scratch = ffPushInputStream((FileStream *) TOS ); + if( Scratch ) + { + M_THROW(Scratch); + } + else M_DROP; + endcase; + + case ID_SWAP: + Scratch = TOS; + TOS = *STKPTR; + *STKPTR = Scratch; + endcase; + + case ID_TEST1: + PUSH_TOS; + M_PUSH( 0x11 ); + M_PUSH( 0x22 ); + TOS = 0x33; + endcase; + + case ID_TEST2: + endcase; + + case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */ + if(TOS) + { + M_THROW(TOS); + } + else M_DROP; + endcase; + +#ifndef PF_NO_SHELL + case ID_TICK: + PUSH_TOS; + CharPtr = (char *) ffWord( (char) ' ' ); + TOS = ffFind( CharPtr, (ExecToken *) &Temp ); + if( TOS == 0 ) + { + ERR("' could not find "); + ioType( (char *) CharPtr+1, *CharPtr ); + M_THROW(-13); + } + else + { + TOS = Temp; + } + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_TIMES: BINARY_OP( * ); endcase; + + case ID_TYPE: + Scratch = M_POP; /* addr */ + ioType( (char *) Scratch, TOS ); + M_DROP; + endcase; + + case ID_TO_R: + M_R_PUSH( TOS ); + M_DROP; + endcase; + + case ID_VAR_BASE: DO_VAR(gVarBase); endcase; + case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase; + case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase; + case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase; + case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase; + case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase; + case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase; + case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase; + case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase; + case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase; + case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase; + case ID_VAR_STATE: DO_VAR(gVarState); endcase; + case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase; + case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase; + case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase; + case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase; + case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase; + + case ID_WORD: + TOS = (cell_t) ffWord( (char) TOS ); + endcase; + + case ID_WORD_FETCH: /* ( waddr -- w ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS); + } + else + { + TOS = *((uint16_t *)TOS); + } +#else + TOS = *((uint16_t *)TOS); +#endif + endcase; + + case ID_WORD_STORE: /* ( w waddr -- ) */ + +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP); + } + else + { + *((uint16_t *)TOS) = (uint16_t) M_POP; + } +#else + *((uint16_t *)TOS) = (uint16_t) M_POP; +#endif + M_DROP; + endcase; + + case ID_XOR: BINARY_OP( ^ ); endcase; + + +/* Branch is followed by an offset relative to address of offset. */ + case ID_ZERO_BRANCH: +DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr )); + if( TOS == 0 ) + { + M_BRANCH; + } + else + { + InsPtr++; /* skip over offset */ + } + M_DROP; +DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr )); + endcase; + + default: + ERR("pfCatch: Unrecognised token = 0x"); + ffDotHex(Token); + ERR(" at 0x"); + ffDotHex((cell_t) InsPtr); + EMIT_CR; + InsPtr = 0; + endcase; + } + + if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */ + +#ifdef PF_DEBUG + M_DOTS; +#endif + +#if 0 + if( _CrtCheckMemory() == 0 ) + { + ERR("_CrtCheckMemory abort: InsPtr = 0x"); + ffDotHex((int)InsPtr); + ERR("\n"); + } +#endif + + } while( (InitialReturnStack - TORPTR) > 0 ); + + SAVE_REGISTERS; + + return ExceptionReturnCode; +} diff --git a/csrc/pf_io.c b/csrc/pf_io.c index dc5a9dc..3aedb49 100644 --- a/csrc/pf_io.c +++ b/csrc/pf_io.c @@ -1,225 +1,225 @@ -/* @(#) 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 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.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 0 ) /* Don't go beyond beginning of line. */ + { + EMIT(BACKSPACE); + EMIT(' '); + EMIT(BACKSPACE); + p--; + len--; + } + break; + + default: + sdTerminalEcho( (char) c ); + *p++ = (char) c; + len++; + break; + } + + } + +gotline: + sdDisableInput(); + sdTerminalEcho( SPACE ); + +/* NUL terminate line to simplify printing when debugging. */ + if( len < maxChars ) p[len] = '\0'; + + return len; +} + +#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); } + + +/***********************************************************************************/ +/*********** File I/O **************************************************************/ +/***********************************************************************************/ +#ifdef PF_NO_FILEIO + +/* Provide stubs for standard file I/O */ + +FileStream *PF_STDIN; +FileStream *PF_STDOUT; + +cell_t sdInputChar( FileStream *stream ) +{ + UNIMPLEMENTED("sdInputChar"); + TOUCH(stream); + return -1; +} + +FileStream *sdOpenFile( const char *FileName, const char *Mode ) +{ + UNIMPLEMENTED("sdOpenFile"); + TOUCH(FileName); + TOUCH(Mode); + return NULL; +} +cell_t sdFlushFile( FileStream * Stream ) +{ + TOUCH(Stream); + return 0; +} +cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdReadFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdWriteFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode ) +{ + UNIMPLEMENTED("sdSeekFile"); + TOUCH(Stream); + TOUCH(Position); + TOUCH(Mode); + return 0; +} +cell_t sdTellFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdTellFile"); + TOUCH(Stream); + return 0; +} +cell_t sdCloseFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdCloseFile"); + TOUCH(Stream); + return 0; +} + +FileStream *sdDeleteFile( const char *FileName ) +{ + UNIMPLEMENTED("sdDeleteFile"); + TOUCH(FileName); + return NULL; +} +#endif + diff --git a/csrc/pf_io.h b/csrc/pf_io.h index beb3495..e03b034 100644 --- a/csrc/pf_io.h +++ b/csrc/pf_io.h @@ -1,162 +1,162 @@ -/* @(#) 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 */ +/* @(#) pf_io.h 98/01/26 1.2 */ +#ifndef _pf_io_h +#define _pf_io_h + +/*************************************************************** +** Include file for PForth IO +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#define PF_CHAR_XON (0x11) +#define PF_CHAR_XOFF (0x13) + +int sdTerminalOut( char c ); +int sdTerminalEcho( char c ); +int sdTerminalFlush( void ); +int sdTerminalIn( void ); +int sdQueryTerminal( void ); +void sdTerminalInit( void ); +void sdTerminalTerm( void ); + +void ioInit( void ); +void ioTerm( void ); + + +#ifdef PF_NO_CHARIO + void sdEnableInput( void ); + void sdDisableInput( void ); + +#else /* PF_NO_CHARIO */ + #ifdef PF_USER_CHARIO +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ +/* If your sdTerminalIn echos, define PF_KEY_ECHOS. */ + #include PF_USER_CHARIO + #else + #define sdEnableInput() /* sdTerminalOut( PF_CHAR_XON ) */ + #define sdDisableInput() /* sdTerminalOut( PF_CHAR_XOFF ) */ + + #endif +#endif /* PF_NO_CHARIO */ + +/* Define file access modes. */ +/* User can #undef and re#define using PF_USER_FILEIO if needed. */ +#define PF_FAM_READ_ONLY (0) +#define PF_FAM_READ_WRITE (1) +#define PF_FAM_WRITE_ONLY (2) +#define PF_FAM_BINARY_FLAG (8) + +#define PF_FAM_CREATE_WO ("w") +#define PF_FAM_CREATE_RW ("w+") +#define PF_FAM_OPEN_RO ("r") +#define PF_FAM_OPEN_RW ("r+") +#define PF_FAM_BIN_CREATE_WO ("wb") +#define PF_FAM_BIN_CREATE_RW ("wb+") +#define PF_FAM_BIN_OPEN_RO ("rb") +#define PF_FAM_BIN_OPEN_RW ("rb+") + +#ifdef PF_NO_FILEIO + + typedef void FileStream; + + extern FileStream *PF_STDIN; + extern FileStream *PF_STDOUT; + + #ifdef __cplusplus + extern "C" { + #endif + + /* Prototypes for stubs. */ + FileStream *sdOpenFile( const char *FileName, const char *Mode ); + cell_t sdFlushFile( FileStream * Stream ); + cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ); + cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ); + cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode ); + off_t sdTellFile( FileStream * Stream ); + cell_t sdCloseFile( FileStream * Stream ); + cell_t sdInputChar( FileStream *stream ); + + #ifdef __cplusplus + } + #endif + + #define PF_SEEK_SET (0) + #define PF_SEEK_CUR (1) + #define PF_SEEK_END (2) + /* + ** printf() is only used for debugging purposes. + ** It is not required for normal operation. + */ + #define PRT(x) /* No printf(). */ + +#else + + #ifdef PF_USER_FILEIO +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ + #include PF_USER_FILEIO + + #else + typedef FILE FileStream; + + #define sdOpenFile fopen + #define sdDeleteFile remove + #define sdFlushFile fflush + #define sdReadFile fread + #define sdWriteFile fwrite + #if defined(WIN32) || defined(__NT__) + /* TODO To support 64-bit file offset we probably need fseeki64(). */ + #define sdSeekFile fseek + #define sdTellFile ftell + #else + #define sdSeekFile fseeko + #define sdTellFile ftello + #endif + #define sdCloseFile fclose + #define sdInputChar fgetc + + #define PF_STDIN ((FileStream *) stdin) + #define PF_STDOUT ((FileStream *) stdout) + + #define PF_SEEK_SET (0) + #define PF_SEEK_CUR (1) + #define PF_SEEK_END (2) + + /* + ** printf() is only used for debugging purposes. + ** It is not required for normal operation. + */ + #define PRT(x) { printf x; sdFlushFile(PF_STDOUT); } + #endif + +#endif /* PF_NO_FILEIO */ + + +#ifdef __cplusplus +extern "C" { +#endif + +cell_t ioAccept( char *Target, cell_t n1 ); +cell_t ioKey( void); +void ioEmit( char c ); +void ioType( const char *s, cell_t n); + +#ifdef __cplusplus +} +#endif + +#endif /* _pf_io_h */ diff --git a/csrc/pf_io_none.c b/csrc/pf_io_none.c index 0c4d1b3..feb14e5 100644 --- a/csrc/pf_io_none.c +++ b/csrc/pf_io_none.c @@ -1,49 +1,49 @@ -/* $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 +/* $Id$ */ +/*************************************************************** +** I/O subsystem for PForth when NO CHARACTER I/O is supported. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 941004 PLB Extracted IO calls from pforth_main.c +***************************************************************/ + +#include "pf_all.h" + + +#ifdef PF_NO_CHARIO +int sdTerminalOut( char c ) +{ + TOUCH(c); + return 0; +} +int sdTerminalEcho( char c ) +{ + TOUCH(c); + return 0; +} +int sdTerminalIn( void ) +{ + return -1; +} +int sdTerminalFlush( void ) +{ + return -1; +} +void sdTerminalInit( void ) +{ +} +void sdTerminalTerm( void ) +{ +} +#endif diff --git a/csrc/pf_main.c b/csrc/pf_main.c index a973553..5783f0f 100644 --- a/csrc/pf_main.c +++ b/csrc/pf_main.c @@ -1,148 +1,148 @@ -/* @(#) 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 - #define ERR(msg) { printf msg; } -#endif - -#include "pforth.h" - -#ifndef PF_DEFAULT_DICTIONARY -#define PF_DEFAULT_DICTIONARY "pforth.dic" -#endif - -#ifdef __MWERKS__ - #include - #include -#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 + #define ERR(msg) { printf msg; } +#endif + +#include "pforth.h" + +#ifndef PF_DEFAULT_DICTIONARY +#define PF_DEFAULT_DICTIONARY "pforth.dic" +#endif + +#ifdef __MWERKS__ + #include + #include +#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; idlln_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 */ +/*************************************************************** +** Memory allocator for systems that don't have real one. +** This might be useful when bringing up a new computer with no OS. +** +** For PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + +#include "pf_all.h" + + +#ifdef PF_NO_MALLOC + +static char *gMemPoolPtr; +static ucell_t gMemPoolSize; + +/* CUSTOM: Make the memory pool bigger if you want. */ +#ifndef PF_MEM_POOL_SIZE + #define PF_MEM_POOL_SIZE (0x100000) +#endif + +#define PF_MEM_BLOCK_SIZE (16) + +#ifndef PF_MALLOC_ADDRESS + static char MemoryPool[PF_MEM_POOL_SIZE]; + #define PF_MALLOC_ADDRESS MemoryPool +#endif + +/********************************************************** +** Doubly Linked List Tools +**********************************************************/ + +typedef struct DoublyLinkedListNode_s +{ + struct DoublyLinkedListNode_s *dlln_Next; + struct DoublyLinkedListNode_s *dlln_Previous; +} DoublyLinkedListNode; + +typedef struct DoublyLinkedList_s +{ + DoublyLinkedListNode *dll_First; + DoublyLinkedListNode *dll_Null; + DoublyLinkedListNode *dll_Last; +} DoublyLinkedList; + +#define dllPreviousNode(n) ((n)->dlln_Previous) +#define dllNextNode(n) ((n)->dlln_Next) + +void dllSetupList( DoublyLinkedList *dll ) +{ + dll->dll_First = &(dll->dll_Null); + dll->dll_Null = (DoublyLinkedListNode *) NULL; + dll->dll_Last = &(dll->dll_First); +} + +void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 ) +{ + Node0->dlln_Next = Node1; + Node1->dlln_Previous = Node0; +} + +void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr, + DoublyLinkedListNode *NodeInListPtr ) +{ + DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr ); + dllLinkNodes( NodePreviousPtr, NewNodePtr ); + dllLinkNodes( NewNodePtr, NodeInListPtr ); +} + +void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr, + DoublyLinkedListNode *NodeInListPtr ) +{ + DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr ); + dllLinkNodes( NodeInListPtr, NewNodePtr ); + dllLinkNodes( NewNodePtr, NodeNextPtr ); +} + +void dllDumpNode( DoublyLinkedListNode *NodePtr ) +{ + TOUCH(NodePtr); + DBUG((" 0x%x -> (0x%x) -> 0x%x\n", + dllPreviousNode( NodePtr ), NodePtr, + dllNextNode( NodePtr ) )); +} + +cell_t dllCheckNode( DoublyLinkedListNode *NodePtr ) +{ + if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) || + (NodePtr->dlln_Previous->dlln_Next != NodePtr)) + { + ERR("dllCheckNode: Bad Node!\n"); + dllDumpNode( dllPreviousNode( NodePtr ) ); + dllDumpNode( NodePtr ); + dllDumpNode( dllNextNode( NodePtr ) ); + return -1; + } + else + { + return 0; + } +} +void dllRemoveNode( DoublyLinkedListNode *NodePtr ) +{ + if( dllCheckNode( NodePtr ) == 0 ) + { + dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) ); + } +} + +void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) +{ + dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First ); +} + +void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) +{ + dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last ); +} + +#define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) ) +#define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL ) +#define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) ) +#define dllFirstNode( l ) ((l)->dll_First) + +static DoublyLinkedList gMemList; + +typedef struct MemListNode +{ + DoublyLinkedListNode mln_Node; + cell_t mln_Size; +} MemListNode; + +#ifdef PF_DEBUG +/*************************************************************** +** Dump memory list. +*/ +void maDumpList( void ) +{ + MemListNode *mln; + + MSG("PForth MemList\n"); + + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + MSG(" Node at = 0x"); ffDotHex(mln); + MSG_NUM_H(", size = 0x", mln->mln_Size); + } +} +#endif + + +/*************************************************************** +** Free mem of any size. +*/ +static void pfFreeRawMem( char *Mem, cell_t NumBytes ) +{ + MemListNode *mln, *FreeNode; + MemListNode *AdjacentLower = NULL; + MemListNode *AdjacentHigher = NULL; + MemListNode *NextBiggest = NULL; + +/* Allocate in whole blocks of 16 bytes */ + DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes )); + NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); + DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes )); + +/* Check memory alignment. */ + if( ( ((cell_t)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0) + { + MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (cell_t) Mem ); + return; + } + +/* Scan list from low to high looking for various nodes. */ + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + if( (((char *) mln) + mln->mln_Size) == Mem ) + { + AdjacentLower = mln; + } + else if( ((char *) mln) == ( Mem + NumBytes )) + { + AdjacentHigher = mln; + } +/* is this the next biggest node. */ + else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) ) + { + NextBiggest = mln; + } + } + +/* Check to see if we can merge nodes. */ + if( AdjacentHigher ) + { +DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher )); + NumBytes += AdjacentHigher->mln_Size; + dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher ); + } + if( AdjacentLower ) + { +DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem )); + AdjacentLower->mln_Size += NumBytes; + } + else + { +DBUG((" Link before 0x%x\n", NextBiggest )); + FreeNode = (MemListNode *) Mem; + FreeNode->mln_Size = NumBytes; + if( NextBiggest == NULL ) + { +/* Nothing bigger so add to end of list. */ + dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode ); + } + else + { +/* Add this node before the next biggest one we found. */ + dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode, + (DoublyLinkedListNode *) NextBiggest ); + } + } + +/* maDumpList(); */ +} + + + +/*************************************************************** +** Setup memory list. Initialize allocator. +*/ +static void pfInitMemBlock( void *addr, ucell_t poolSize ) +{ + char *AlignedMemory; + cell_t AlignedSize; + + pfDebugMessage("pfInitMemBlock()\n"); +/* Set globals. */ + gMemPoolPtr = addr; + gMemPoolSize = poolSize; + + dllSetupList( &gMemList ); + +/* Adjust to next highest aligned memory location. */ + AlignedMemory = (char *) ((((cell_t)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) & + ~(PF_MEM_BLOCK_SIZE - 1)); + +/* Adjust size to reflect aligned memory. */ + AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr); + +/* Align size of pool. */ + AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1); + +/* Free to pool. */ + pfFreeRawMem( AlignedMemory, AlignedSize ); + +} + +/*************************************************************** +** Allocate mem from list of free nodes. +*/ +static char *pfAllocRawMem( cell_t NumBytes ) +{ + char *Mem = NULL; + MemListNode *mln; + pfDebugMessage("pfAllocRawMem()\n"); + + if( NumBytes <= 0 ) return NULL; + +/* Allocate in whole blocks of 16 bytes */ + NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); + + DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes )); + +/* Scan list from low to high until we find a node big enough. */ + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + if( mln->mln_Size >= NumBytes ) + { + cell_t RemSize; + + Mem = (char *) mln; + +/* Remove this node from list. */ + dllRemoveNode( (DoublyLinkedListNode *) mln ); + +/* Is there enough left in block to make it worth splitting? */ + RemSize = mln->mln_Size - NumBytes; + if( RemSize >= PF_MEM_BLOCK_SIZE ) + { + pfFreeRawMem( (Mem + NumBytes), RemSize ); + } + break; + } + + } +/* maDumpList(); */ + DBUG(("Allocate mem at 0x%x.\n", Mem )); + return Mem; +} + +/*************************************************************** +** Keep mem size at first cell. +*/ +char *pfAllocMem( cell_t NumBytes ) +{ + cell_t *IntMem; + + if( NumBytes <= 0 ) return NULL; + +/* Allocate an extra cell for size. */ + NumBytes += sizeof(cell_t); + + IntMem = (cell_t *)pfAllocRawMem( NumBytes ); + + if( IntMem != NULL ) *IntMem++ = NumBytes; + + return (char *) IntMem; +} + +/*************************************************************** +** Free mem with mem size at first cell. +*/ +void pfFreeMem( void *Mem ) +{ + cell_t *IntMem; + cell_t NumBytes; + + if( Mem == NULL ) return; + +/* Allocate an extra cell for size. */ + IntMem = (cell_t *) Mem; + IntMem--; + NumBytes = *IntMem; + + pfFreeRawMem( (char *) IntMem, NumBytes ); + +} + +void pfInitMemoryAllocator( void ) +{ + pfInitMemBlock( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE ); +} +#else /* PF_NO_MALLOC */ + +int not_an_empty_file; /* Stops nasty compiler warnings when PF_NO_MALLOC not defined. */ + +#endif /* PF_NO_MALLOC */ diff --git a/csrc/pf_mem.h b/csrc/pf_mem.h index 9f8beda..24b7e17 100644 --- a/csrc/pf_mem.h +++ b/csrc/pf_mem.h @@ -1,47 +1,47 @@ -/* @(#) 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_mem.h 98/01/26 1.3 */ +#ifndef _pf_mem_h +#define _pf_mem_h + +/*************************************************************** +** Include file for PForth Fake Memory Allocator +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +***************************************************************/ + +#ifdef PF_NO_MALLOC + + #ifdef __cplusplus + extern "C" { + #endif + + void pfInitMemoryAllocator( void ); + char *pfAllocMem( cell_t NumBytes ); + void pfFreeMem( void *Mem ); + + #ifdef __cplusplus + } + #endif + +#else + + #ifdef PF_USER_MALLOC +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ + #include PF_USER_MALLOC + #else + #define pfInitMemoryAllocator() + #define pfAllocMem malloc + #define pfFreeMem free + #endif + +#endif /* PF_NO_MALLOC */ + +#endif /* _pf_mem_h */ diff --git a/csrc/pf_save.c b/csrc/pf_save.c index 80b4c1e..2baf297 100644 --- a/csrc/pf_save.c +++ b/csrc/pf_save.c @@ -1,844 +1,844 @@ -/* @(#) 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 - -#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>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.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 + +#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>56); + *addr++ = (uint8_t) (data>>48); + *addr++ = (uint8_t) (data>>40); + *addr++ = (uint8_t) (data>>32); + } + *addr++ = (uint8_t) (data>>24); + *addr++ = (uint8_t) (data>>16); + *addr++ = (uint8_t) (data>>8); + *addr = (uint8_t) (data); +} + +/***************************************************************/ +void Write32BigEndian( uint8_t *addr, uint32_t data ) +{ + *addr++ = (uint8_t) (data>>24); + *addr++ = (uint8_t) (data>>16); + *addr++ = (uint8_t) (data>>8); + *addr = (uint8_t) (data); +} + +/***************************************************************/ +void Write16BigEndian( uint8_t *addr, uint16_t data ) +{ + *addr++ = (uint8_t) (data>>8); + *addr = (uint8_t) (data); +} + +/***************************************************************/ +void WriteCellLittleEndian( uint8_t *addr, ucell_t data ) +{ + /* Write should be in order of increasing address + * to optimize for burst writes to DRAM. */ + if( sizeof(ucell_t) == 8 ) + { + *addr++ = (uint8_t) data; /* LSB at near end */ + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + } + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr = (uint8_t) data; +} +/***************************************************************/ +void Write32LittleEndian( uint8_t *addr, uint32_t data ) +{ + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr++ = (uint8_t) data; + data = data >> 8; + *addr = (uint8_t) data; +} + +/***************************************************************/ +void Write16LittleEndian( uint8_t *addr, uint16_t data ) +{ + *addr++ = (uint8_t) data; + data = data >> 8; + *addr = (uint8_t) data; +} + +/***************************************************************/ +/* Return 1 if host CPU is Little Endian */ +int IsHostLittleEndian( void ) +{ + static int gEndianCheck = 1; + unsigned char *bp = (unsigned char *) &gEndianCheck; + return (int) (*bp); /* Return byte pointed to by address. If LSB then == 1 */ +} + +#if defined(PF_NO_FILEIO) || defined(PF_NO_SHELL) + +cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize) +{ + TOUCH(FileName); + TOUCH(EntryPoint); + TOUCH(NameSize); + TOUCH(CodeSize); + + pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED); + return -1; +} + +#else /* PF_NO_FILEIO or PF_NO_SHELL */ + +/***************************************************************/ +static int Write32ToFile( FileStream *fid, uint32_t Val ) +{ + int numw; + uint8_t pad[4]; + + Write32BigEndian(pad,Val); + numw = sdWriteFile( pad, 1, sizeof(pad), fid ); + if( numw != sizeof(pad) ) return -1; + return 0; +} + +/***************************************************************/ +static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t NumBytes ) +{ + cell_t numw; + cell_t EvenNumW; + + EvenNumW = EVENUP(NumBytes); + + if( Write32ToFile( fid, ID ) < 0 ) goto error; + if( Write32ToFile( fid, EvenNumW ) < 0 ) goto error; + + numw = sdWriteFile( Data, 1, EvenNumW, fid ); + if( numw != EvenNumW ) goto error; + return 0; +error: + pfReportError("WriteChunkToFile", PF_ERR_WRITE_FILE); + return -1; +} + +/* Convert dictionary info chunk between native and on-disk (big-endian). */ +static void +convertDictionaryInfoWrite (DictionaryInfoChunk *sd) +{ +/* Convert all fields in DictionaryInfoChunk from Native to BigEndian. + * This assumes they are all 32-bit integers. + */ + int i; + uint32_t *p = (uint32_t *) sd; + for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++) + { + Write32BigEndian( (uint8_t *)&p[i], p[i] ); + } +} + +static void +convertDictionaryInfoRead (DictionaryInfoChunk *sd) +{ +/* Convert all fields in structure from BigEndian to Native. */ + int i; + uint32_t *p = (uint32_t *) sd; + for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++) + { + p[i] = Read32BigEndian( (uint8_t *)&p[i] ); + } +} + +/**************************************************************** +** Save Dictionary in File. +** If EntryPoint is NULL, save as development environment. +** If EntryPoint is non-NULL, save as turnKey environment with no names. +*/ +cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize) +{ + FileStream *fid; + DictionaryInfoChunk SD; + uint32_t FormSize; + uint32_t NameChunkSize = 0; + uint32_t CodeChunkSize; + uint32_t relativeCodePtr; + + fid = sdOpenFile( FileName, "wb" ); + if( fid == NULL ) + { + pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE); + return -1; + } + +/* Save in uninitialized form. */ + pfExecIfDefined("AUTO.TERM"); + +/* Write FORM Header ---------------------------- */ + if( Write32ToFile( fid, ID_FORM ) < 0 ) goto error; + if( Write32ToFile( fid, 0 ) < 0 ) goto error; + if( Write32ToFile( fid, ID_P4TH ) < 0 ) goto error; + +/* Write P4DI Dictionary Info ------------------ */ + SD.sd_Version = PF_FILE_VERSION; + + relativeCodePtr = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */ + SD.sd_RelCodePtr = relativeCodePtr; + SD.sd_UserStackSize = sizeof(cell_t) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit); + SD.sd_ReturnStackSize = sizeof(cell_t) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit); + SD.sd_NumPrimitives = gNumPrimitives; /* Must match compiled dictionary. */ + +#ifdef PF_SUPPORT_FP + SD.sd_FloatSize = sizeof(PF_FLOAT); /* Must match compiled dictionary. */ +#else + SD.sd_FloatSize = 0; +#endif + + SD.sd_CellSize = sizeof(cell_t); + +/* Set bit that specifies whether dictionary is BIG or LITTLE Endian. */ + { +#if defined(PF_BIG_ENDIAN_DIC) + int eflag = SD_F_BIG_ENDIAN_DIC; +#elif defined(PF_LITTLE_ENDIAN_DIC) + int eflag = 0; +#else + int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC; +#endif + SD.sd_Flags = eflag; + } + + if( EntryPoint ) + { + SD.sd_EntryPoint = EntryPoint; /* Turnkey! */ + } + else + { + SD.sd_EntryPoint = 0; + } + +/* Do we save names? */ + if( NameSize == 0 ) + { + SD.sd_RelContext = 0; + SD.sd_RelHeaderPtr = 0; + SD.sd_NameSize = 0; + } + else + { + uint32_t relativeHeaderPtr; +/* Development mode. */ + SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext); + relativeHeaderPtr = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr); + SD.sd_RelHeaderPtr = relativeHeaderPtr; + +/* How much real name space is there? */ + NameChunkSize = QUADUP(relativeHeaderPtr); /* Align */ + +/* NameSize must be 0 or greater than NameChunkSize + 1K */ + NameSize = QUADUP(NameSize); /* Align */ + if( NameSize > 0 ) + { + NameSize = MAX( NameSize, (NameChunkSize + 1024) ); + } + SD.sd_NameSize = NameSize; + } + +/* How much real code is there? */ + CodeChunkSize = QUADUP(relativeCodePtr); + CodeSize = QUADUP(CodeSize); /* Align */ + CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) ); + SD.sd_CodeSize = CodeSize; + + + convertDictionaryInfoWrite (&SD); + + if( WriteChunkToFile( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error; + +/* Write Name Fields if NameSize non-zero ------- */ + if( NameSize > 0 ) + { + if( WriteChunkToFile( fid, ID_P4NM, (char *) NAME_BASE, + NameChunkSize ) < 0 ) goto error; + } + +/* Write Code Fields ---------------------------- */ + if( WriteChunkToFile( fid, ID_P4CD, (char *) CODE_BASE, + CodeChunkSize ) < 0 ) goto error; + + FormSize = sdTellFile( fid ) - 8; + sdSeekFile( fid, 4, PF_SEEK_SET ); + if( Write32ToFile( fid, FormSize ) < 0 ) goto error; + + sdCloseFile( fid ); + +/* Restore initialization. */ + pfExecIfDefined("AUTO.INIT"); + return 0; + +error: + sdSeekFile( fid, 0, PF_SEEK_SET ); + Write32ToFile( fid, ID_BADF ); /* Mark file as bad. */ + sdCloseFile( fid ); + +/* Restore initialization. */ + pfExecIfDefined("AUTO.INIT"); + + return -1; +} + +#endif /* !PF_NO_FILEIO and !PF_NO_SHELL */ + + +#ifndef PF_NO_FILEIO + +/***************************************************************/ +static int32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr ) +{ + int32_t numr; + uint8_t pad[4]; + numr = sdReadFile( pad, 1, sizeof(pad), fid ); + if( numr != sizeof(pad) ) return -1; + *ValPtr = Read32BigEndian( pad ); + return 0; +} + +/***************************************************************/ +PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + pfDictionary_t *dic = NULL; + FileStream *fid; + DictionaryInfoChunk *sd; + uint32_t ChunkID; + uint32_t ChunkSize; + uint32_t FormSize; + uint32_t BytesLeft; + uint32_t numr; + int isDicBigEndian; + +DBUG(("pfLoadDictionary( %s )\n", FileName )); + +/* Open file. */ + fid = sdOpenFile( FileName, "rb" ); + if( fid == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE); + goto xt_error; + } + +/* Read FORM, Size, ID */ + if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; + if( ChunkID != ID_FORM ) + { + pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE); + goto error; + } + + if (Read32FromFile( fid, &FormSize ) < 0) goto read_error; + BytesLeft = FormSize; + + if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; + BytesLeft -= 4; + if( ChunkID != ID_P4TH ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE); + goto error; + } + +/* Scan and parse all chunks in file. */ + while( BytesLeft > 0 ) + { + if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; + if (Read32FromFile( fid, &ChunkSize ) < 0) goto read_error; + BytesLeft -= 8; + + DBUG(("ChunkID = %4s, Size = %d\n", (char *)&ChunkID, ChunkSize )); + + switch( ChunkID ) + { + case ID_P4DI: + sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize ); + if( sd == NULL ) goto nomem_error; + + numr = sdReadFile( sd, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; + + convertDictionaryInfoRead (sd); + + isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC; + + if( !gVarQuiet ) + { + MSG("pForth loading dictionary from file "); MSG(FileName); + EMIT_CR; + MSG_NUM_D(" File format version is ", sd->sd_Version ); + MSG_NUM_D(" Name space size = ", sd->sd_NameSize ); + MSG_NUM_D(" Code space size = ", sd->sd_CodeSize ); + MSG_NUM_D(" Entry Point = ", sd->sd_EntryPoint ); + MSG_NUM_D(" Cell Size = ", sd->sd_CellSize ); + MSG( (isDicBigEndian ? " Big Endian Dictionary" : + " Little Endian Dictionary") ); + if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!"); + EMIT_CR; + } + + if( sd->sd_Version > PF_FILE_VERSION ) + { + pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE ); + goto error; + } + if( sd->sd_Version < PF_EARLIEST_FILE_VERSION ) + { + pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST ); + goto error; + } + if( sd->sd_CellSize != sizeof(cell_t) ) + { + pfReportError("pfLoadDictionary", PF_ERR_CELL_SIZE_CONFLICT ); + goto error; + } + if( sd->sd_NumPrimitives > NUM_PRIMITIVES ) + { + pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED ); + goto error; + } + +/* Check to make sure that EndianNess of dictionary matches mode of pForth. */ +#if defined(PF_BIG_ENDIAN_DIC) + if(isDicBigEndian == 0) +#elif defined(PF_LITTLE_ENDIAN_DIC) + if(isDicBigEndian == 1) +#else + if( isDicBigEndian == IsHostLittleEndian() ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); + goto error; + } + +/* Check for compatible float size. */ +#ifdef PF_SUPPORT_FP + if( sd->sd_FloatSize != sizeof(PF_FLOAT) ) +#else + if( sd->sd_FloatSize != 0 ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT ); + goto error; + } + + dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize ); + if( dic == NULL ) goto nomem_error; + gCurrentDictionary = dic; + if( sd->sd_NameSize > 0 ) + { + gVarContext = NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */ + gCurrentDictionary->dic_HeaderPtr = (ucell_t)(uint8_t *) + NAMEREL_TO_ABS(sd->sd_RelHeaderPtr); + } + else + { + gVarContext = 0; + gCurrentDictionary->dic_HeaderPtr = (ucell_t)NULL; + } + gCurrentDictionary->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(sd->sd_RelCodePtr); + gNumPrimitives = sd->sd_NumPrimitives; /* Must match compiled dictionary. */ +/* Pass EntryPoint back to caller. */ + if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint; + pfFreeMem(sd); + break; + + case ID_P4NM: +#ifdef PF_NO_SHELL + pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL ); + goto error; +#else + if( NAME_BASE == 0 ) + { + pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES ); + goto error; + } + if( gCurrentDictionary == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + goto error; + } + if( ChunkSize > NAME_SIZE ) + { + pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); + goto error; + } + numr = sdReadFile( (char *) NAME_BASE, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; +#endif /* PF_NO_SHELL */ + break; + + case ID_P4CD: + if( gCurrentDictionary == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + goto error; + } + if( ChunkSize > CODE_SIZE ) + { + pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); + goto error; + } + numr = sdReadFile( (uint8_t *) CODE_BASE, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; + break; + + default: + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + sdSeekFile( fid, ChunkSize, PF_SEEK_CUR ); + break; + } + } + + sdCloseFile( fid ); + + if( NAME_BASE != 0) + { + cell_t Result; +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + goto error; + } + } + +DBUG(("pfLoadDictionary: return %p\n", dic)); + return (PForthDictionary) dic; + +nomem_error: + pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); + sdCloseFile( fid ); + return NULL; + +read_error: + pfReportError("pfLoadDictionary", PF_ERR_READ_FILE); +error: + sdCloseFile( fid ); +xt_error: + return NULL; +} + +#else + +PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + (void) FileName; + (void) EntryPointPtr; + return NULL; +} +#endif /* !PF_NO_FILEIO */ + + + +/***************************************************************/ +PForthDictionary pfLoadStaticDictionary( void ) +{ +#ifdef PF_STATIC_DIC + cell_t Result; + pfDictionary_t *dic; + cell_t NewNameSize, NewCodeSize; + + if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) + { + MSG( (IF_LITTLE_ENDIAN ? + "Little Endian Dictionary on " : + "Big Endian Dictionary on ") ); + MSG( (IsHostLittleEndian() ? + "Little Endian CPU" : + "Big Endian CPU") ); + EMIT_CR; + } + +/* Check to make sure that EndianNess of dictionary matches mode of pForth. */ +#if defined(PF_BIG_ENDIAN_DIC) + if(IF_LITTLE_ENDIAN == 1) +#elif defined(PF_LITTLE_ENDIAN_DIC) + if(IF_LITTLE_ENDIAN == 0) +#else /* Code is native endian! */ + if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) +#endif + { + pfReportError("pfLoadStaticDictionary", PF_ERR_ENDIAN_CONFLICT ); + goto error; + } + + +#ifndef PF_EXTRA_HEADERS + #define PF_EXTRA_HEADERS (20000) +#endif +#ifndef PF_EXTRA_CODE + #define PF_EXTRA_CODE (40000) +#endif + +/* Copy static const data to allocated dictionaries. */ + NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS; + NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE; + + DBUG_NUM_D( "static dic name size = ", NewNameSize ); + DBUG_NUM_D( "static dic code size = ", NewCodeSize ); + + gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize ); + if( !dic ) goto nomem_error; + + pfCopyMemory( (uint8_t *) dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) ); + pfCopyMemory( (uint8_t *) dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) ); + DBUG(("Static data copied to newly allocated dictionaries.\n")); + + dic->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(CODEPTR); + gNumPrimitives = NUM_PRIMITIVES; + + if( NAME_BASE != 0) + { +/* Setup name space. */ + dic->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(HEADERPTR); + gVarContext = NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */ + +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadStaticDictionary: FindSpecialXTs", Result); + goto error; + } + } + + return (PForthDictionary) dic; + +error: + return NULL; + +nomem_error: + pfReportError("pfLoadStaticDictionary", PF_ERR_NO_MEM); +#endif /* PF_STATIC_DIC */ + + return NULL; +} + diff --git a/csrc/pf_save.h b/csrc/pf_save.h index 3bf8c2f..00f2802 100644 --- a/csrc/pf_save.h +++ b/csrc/pf_save.h @@ -1,100 +1,100 @@ -/* @(#) 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_save.h 96/12/18 1.8 */ +#ifndef _pforth_save_h +#define _pforth_save_h + +/*************************************************************** +** Include file for PForth SaveForth +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 941031 rdg fix redefinition of MAKE_ID and EVENUP to be conditional +** +***************************************************************/ + + +typedef struct DictionaryInfoChunk +{ +/* All fields are stored in BIG ENDIAN format for consistency in data files. + * All fields must be the same size for easy endian conversion. + * All fields must be 32 bit for file compatibility with older versions. + */ + int32_t sd_Version; + int32_t sd_RelContext; /* relative ptr to Dictionary Context */ + int32_t sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */ + int32_t sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */ + int32_t sd_EntryPoint; /* relative ptr to entry point or NULL */ + int32_t sd_UserStackSize; /* in bytes */ + int32_t sd_ReturnStackSize; /* in bytes */ + int32_t sd_NameSize; /* in bytes */ + int32_t sd_CodeSize; /* in bytes */ + int32_t sd_NumPrimitives; /* To distinguish between primitive and secondary. */ + uint32_t sd_Flags; + int32_t sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */ + int32_t sd_CellSize; /* In bytes. Must match code. */ +} DictionaryInfoChunk; + +/* Bits in sd_Flags */ +#define SD_F_BIG_ENDIAN_DIC (1<<0) + +#ifndef MAKE_ID +#define MAKE_ID(a,b,c,d) ((((uint32_t)a)<<24)|(((uint32_t)b)<<16)|(((uint32_t)c)<<8)|((uint32_t)d)) +#endif + +#define ID_FORM MAKE_ID('F','O','R','M') +#define ID_P4TH MAKE_ID('P','4','T','H') +#define ID_P4DI MAKE_ID('P','4','D','I') +#define ID_P4NM MAKE_ID('P','4','N','M') +#define ID_P4CD MAKE_ID('P','4','C','D') +#define ID_BADF MAKE_ID('B','A','D','F') + +#ifndef EVENUP +#define EVENUP(n) ((n+1)&(~1)) +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize ); + +/* Endian-ness tools. */ +int IsHostLittleEndian( void ); + +ucell_t ReadCellBigEndian( const uint8_t *addr ); +uint32_t Read32BigEndian( const uint8_t *addr ); +uint16_t Read16BigEndian( const uint8_t *addr ); + +ucell_t ReadCellLittleEndian( const uint8_t *addr ); +uint32_t Read32LittleEndian( const uint8_t *addr ); +uint16_t Read16LittleEndian( const uint8_t *addr ); + +void WriteCellBigEndian( uint8_t *addr, ucell_t data ); +void Write32BigEndian( uint8_t *addr, uint32_t data ); +void Write16BigEndian( uint8_t *addr, uint16_t data ); + +void WriteCellLittleEndian( uint8_t *addr, ucell_t data ); +void Write32LittleEndian( uint8_t *addr, uint32_t data ); +void Write16LittleEndian( uint8_t *addr, uint16_t data ); + +#ifdef PF_SUPPORT_FP +void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data ); +PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr ); +void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data ); +PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr ); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_save_h */ diff --git a/csrc/pf_text.c b/csrc/pf_text.c index 9325851..e48e457 100644 --- a/csrc/pf_text.c +++ b/csrc/pf_text.c @@ -1,407 +1,407 @@ -/* @(#) 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; is2; -*/ -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 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++ '}')) 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.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; is2; +*/ +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 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++ '}')) c = '.'; + EMIT(c); + } + EMIT_CR; + } +} + + +/* Print name, mask off any dictionary bits. */ +void TypeName( const char *Name ) +{ + const char *FirstChar; + cell_t Len; + + FirstChar = Name+1; + Len = *Name & 0x1F; + + ioType( FirstChar, Len ); +} + + + +#ifdef PF_UNIT_TEST +/* Unit test for string conversion routines. */ +#define ASSERT_PAD_IS( index, value, msg ) \ + if( pad[index] != ((char)(value)) ) \ + { \ + ERR(( "ERROR text test failed: " msg "\n")); \ + numErrors += 1; \ + } \ + +cell_t pfUnitTestText( void ) +{ + cell_t numErrors = 0; + char pad[16]; + char fpad[8]; + + /* test CStringToForth */ + pfSetMemory(pad,0xA5,sizeof(pad)); + CStringToForth( pad, "frog", 6 ); + ASSERT_PAD_IS( 0, 4, "CS len 6" ); + ASSERT_PAD_IS( 4, 'g', "CS end 6" ); + ASSERT_PAD_IS( 5, 0xA5, "CS past 6" ); + + pfSetMemory(pad,0xA5,sizeof(pad)); + CStringToForth( pad, "frog", 5 ); + ASSERT_PAD_IS( 0, 4, "CS len 5" ); + ASSERT_PAD_IS( 4, 'g', "CS end 5" ); + ASSERT_PAD_IS( 5, 0xA5, "CS past 5" ); + + pfSetMemory(pad,0xA5,sizeof(pad)); + CStringToForth( pad, "frog", 4 ); + ASSERT_PAD_IS( 0, 3, "CS len 4" ); + ASSERT_PAD_IS( 3, 'o', "CS end 4" ); + ASSERT_PAD_IS( 4, 0xA5, "CS past 4" ); + + /* Make a Forth string for testing ForthStringToC. */ + CStringToForth( fpad, "frog", sizeof(fpad) ); + + pfSetMemory(pad,0xA5,sizeof(pad)); + ForthStringToC( pad, fpad, 6 ); + ASSERT_PAD_IS( 0, 'f', "FS len 6" ); + ASSERT_PAD_IS( 3, 'g', "FS end 6" ); + ASSERT_PAD_IS( 4, 0, "FS nul 6" ); + ASSERT_PAD_IS( 5, 0xA5, "FS past 6" ); + + pfSetMemory(pad,0xA5,sizeof(pad)); + ForthStringToC( pad, fpad, 5 ); + ASSERT_PAD_IS( 0, 'f', "FS len 5" ); + ASSERT_PAD_IS( 3, 'g', "FS end 5" ); + ASSERT_PAD_IS( 4, 0, "FS nul 5" ); + ASSERT_PAD_IS( 5, 0xA5, "FS past 5" ); + + pfSetMemory(pad,0xA5,sizeof(pad)); + ForthStringToC( pad, fpad, 4 ); + ASSERT_PAD_IS( 0, 'f', "FS len 4" ); + ASSERT_PAD_IS( 2, 'o', "FS end 4" ); + ASSERT_PAD_IS( 3, 0, "FS nul 4" ); + ASSERT_PAD_IS( 4, 0xA5, "FS past 4" ); + + return numErrors; +} +#endif diff --git a/csrc/pf_text.h b/csrc/pf_text.h index 29e0218..05431d7 100644 --- a/csrc/pf_text.h +++ b/csrc/pf_text.h @@ -1,71 +1,71 @@ -/* @(#) 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_text.h 96/12/18 1.10 */ +#ifndef _pforth_text_h +#define _pforth_text_h + +/*************************************************************** +** Include file for PForth Text +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#define PF_ERR_INDEX_MASK (0xFFFF) +#define PF_ERR_BASE (0x80000000) +#define PF_ERR_NO_MEM (PF_ERR_BASE | 0) +#define PF_ERR_TOO_BIG (PF_ERR_BASE | 2) +#define PF_ERR_NUM_PARAMS (PF_ERR_BASE | 3) +#define PF_ERR_OPEN_FILE (PF_ERR_BASE | 4) +#define PF_ERR_WRONG_FILE (PF_ERR_BASE | 5) +#define PF_ERR_BAD_FILE (PF_ERR_BASE | 6) +#define PF_ERR_READ_FILE (PF_ERR_BASE | 7) +#define PF_ERR_WRITE_FILE (PF_ERR_BASE | 8) +#define PF_ERR_CORRUPT_DIC (PF_ERR_BASE | 9) +#define PF_ERR_NOT_SUPPORTED (PF_ERR_BASE | 10) +#define PF_ERR_VERSION_FUTURE (PF_ERR_BASE | 11) +#define PF_ERR_VERSION_PAST (PF_ERR_BASE | 12) +#define PF_ERR_COLON_STACK (PF_ERR_BASE | 13) +#define PF_ERR_HEADER_ROOM (PF_ERR_BASE | 14) +#define PF_ERR_CODE_ROOM (PF_ERR_BASE | 15) +#define PF_ERR_NO_SHELL (PF_ERR_BASE | 16) +#define PF_ERR_NO_NAMES (PF_ERR_BASE | 17) +#define PF_ERR_OUT_OF_RANGE (PF_ERR_BASE | 18) +#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19) +#define PF_ERR_FLOAT_CONFLICT (PF_ERR_BASE | 20) +#define PF_ERR_CELL_SIZE_CONFLICT (PF_ERR_BASE | 21) +/* If you add an error code here, also add a text message in "pf_text.c". */ + +#ifdef __cplusplus +extern "C" { +#endif + +void pfReportError( const char *FunctionName, Err ErrCode ); +void pfReportThrow( ThrowCode code ); + +char *ForthStringToC( char *dst, const char *FString, cell_t dstSize ); +char *CStringToForth( char *dst, const char *CString, cell_t dstSize ); + +cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 ); +cell_t ffCompareText( const char *s1, const char *s2, cell_t len ); +cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len ); + +void DumpMemory( void *addr, cell_t cnt); +char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars ); +void TypeName( const char *Name ); + +cell_t pfUnitTestText( void ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_text_h */ diff --git a/csrc/pf_types.h b/csrc/pf_types.h index 95c8e3c..ac4f33b 100644 --- a/csrc/pf_types.h +++ b/csrc/pf_types.h @@ -1,33 +1,33 @@ -/* @(#) 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_types.h 96/12/18 1.3 */ +#ifndef _pf_types_h +#define _pf_types_h + +/*************************************************************** +** Type declarations for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/*************************************************************** +** Type Declarations +***************************************************************/ + +#ifndef Err + typedef long Err; +#endif + +typedef char ForthString; +typedef char *ForthStringPtr; + +#endif /* _pf_types_h */ diff --git a/csrc/pf_win32.h b/csrc/pf_win32.h index 6b14ada..1bb298a 100644 --- a/csrc/pf_win32.h +++ b/csrc/pf_win32.h @@ -1,41 +1,41 @@ -/* @(#) pf_win32.h 98/01/26 1.2 */ -#ifndef _pf_win32_h -#define _pf_win32_h - -#include - -/*************************************************************** -** 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_win32.h 98/01/26 1.2 */ +#ifndef _pf_win32_h +#define _pf_win32_h + +#include + +/*************************************************************** +** WIN32 dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/* Include as PF_USER_INC2 for PCs */ + +/* Modify some existing defines. */ + +/* +** The PC will insert LF characters into the dictionary files unless +** we use "b" mode! +*/ +#undef PF_FAM_CREATE +#define PF_FAM_CREATE ("wb+") + +#undef PF_FAM_OPEN_RO +#define PF_FAM_OPEN_RO ("rb") + +#undef PF_FAM_OPEN_RW +#define PF_FAM_OPEN_RW ("rb+") + +#endif /* _pf_win32_h */ diff --git a/csrc/pf_words.c b/csrc/pf_words.c index 97760b9..7a753ec 100644 --- a/csrc/pf_words.c +++ b/csrc/pf_words.c @@ -1,223 +1,223 @@ -/* @(#) 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 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= 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; itd_IN += (n1-n3) + 1; - return &gScratch[0]; -} +/* @(#) 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 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= 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; itd_IN += (n1-n3) + 1; + return &gScratch[0]; +} diff --git a/csrc/pf_words.h b/csrc/pf_words.h index edf81a1..d4625f3 100644 --- a/csrc/pf_words.h +++ b/csrc/pf_words.h @@ -1,36 +1,36 @@ -/* @(#) 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 */ +/* @(#) pf_words.h 96/12/18 1.7 */ +#ifndef _pforth_words_h +#define _pforth_words_h + +/*************************************************************** +** Include file for PForth Words +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void ffDot( cell_t n ); +void ffDotHex( cell_t n ); +void ffDotS( void ); +cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut ); +cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_words_h */ diff --git a/csrc/pfcompfp.h b/csrc/pfcompfp.h index 0d8d9d0..f65cbc8 100644 --- a/csrc/pfcompfp.h +++ b/csrc/pfcompfp.h @@ -1,78 +1,78 @@ -/* @(#) 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 +/* @(#) pfcompfp.h 96/12/18 1.6 */ +/*************************************************************** +** Compile FP routines. +** This file is included from "pf_compile.c" +** +** These routines could be left out of an execute only version. +** +** Author: Darren Gibbs, Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + + +#ifdef PF_SUPPORT_FP +/* Core words */ + CreateDicEntryC( ID_FP_D_TO_F, "D>F", 0 ); + CreateDicEntryC( ID_FP_FSTORE, "F!", 0 ); + CreateDicEntryC( ID_FP_FTIMES, "F*", 0 ); + CreateDicEntryC( ID_FP_FPLUS, "F+", 0 ); + CreateDicEntryC( ID_FP_FMINUS, "F-", 0 ); + CreateDicEntryC( ID_FP_FSLASH, "F/", 0 ); + CreateDicEntryC( ID_FP_F_ZERO_LESS_THAN, "F0<", 0 ); + CreateDicEntryC( ID_FP_F_ZERO_EQUALS, "F0=", 0 ); + CreateDicEntryC( ID_FP_F_LESS_THAN, "F<", 0 ); + CreateDicEntryC( ID_FP_F_TO_D, "F>D", 0 ); + CreateDicEntryC( ID_FP_FFETCH, "F@", 0 ); + CreateDicEntryC( ID_FP_FDEPTH, "FDEPTH", 0 ); + CreateDicEntryC( ID_FP_FDROP, "FDROP", 0 ); + CreateDicEntryC( ID_FP_FDUP, "FDUP", 0 ); + CreateDicEntryC( ID_FP_FLITERAL, "FLITERAL", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 ); + CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 ); + CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 ); + CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 ); + CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 ); + CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 ); + CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 ); + CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 ); + CreateDicEntryC( ID_FP_FROT, "FROT", 0 ); + CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 ); + CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 ); + +/* Extended words */ + CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 ); + CreateDicEntryC( ID_FP_FABS, "FABS", 0 ); + CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 ); + CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 ); + CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 ); + CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 ); + CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 ); + CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 ); + CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 ); + CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 ); + CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 ); + CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 ); + CreateDicEntryC( ID_FP_FLN, "FLN", 0 ); + CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 ); + CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 ); + CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 ); + CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 ); + CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 ); + CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 ); + CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 ); + CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 ); + CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 ); + +#endif diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index bc4c585..9397fa3 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -1,1187 +1,1187 @@ -/* @(#) 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; itd_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.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; itd_SourceNum; i++ ) + { + char c = gCurrentTask->td_SourcePtr[i]; + if( c == '\t' ) c = ' '; + EMIT(c); + } + EMIT_CR; + for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^'); + EMIT_CR; + } + +/* Pop file stream. */ + ffPopInputStream(); + +/* ANSI spec specifies that this should also close the file. */ + sdCloseFile(InputFile); + + return exception; +} + +#endif /* !PF_NO_SHELL */ + +/*************************************************************** +** Save current input stream on stack, use this new one. +***************************************************************/ +Err ffPushInputStream( FileStream *InputFile ) +{ + cell_t Result = 0; + IncludeFrame *inf; + +/* Push current input state onto special include stack. */ + if( gIncludeIndex < MAX_INCLUDE_DEPTH ) + { + inf = &gIncludeStack[gIncludeIndex++]; + inf->inf_FileID = gCurrentTask->td_InputStream; + inf->inf_IN = gCurrentTask->td_IN; + inf->inf_LineNumber = gCurrentTask->td_LineNumber; + inf->inf_SourceNum = gCurrentTask->td_SourceNum; +/* Copy TIB plus any NUL terminator into saved area. */ + if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) + { + pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 ); + } + +/* Set new current input. */ + DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile )); + gCurrentTask->td_InputStream = InputFile; + gCurrentTask->td_LineNumber = 0; + } + else + { + ERR("ffPushInputStream: max depth exceeded.\n"); + return -1; + } + + + return Result; +} + +/*************************************************************** +** Go back to reading previous stream. +** Just return gCurrentTask->td_InputStream upon underflow. +***************************************************************/ +FileStream *ffPopInputStream( void ) +{ + IncludeFrame *inf; + FileStream *Result; + +DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex)); + Result = gCurrentTask->td_InputStream; + +/* Restore input state. */ + if( gIncludeIndex > 0 ) + { + inf = &gIncludeStack[--gIncludeIndex]; + gCurrentTask->td_InputStream = inf->inf_FileID; + DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream )); + gCurrentTask->td_IN = inf->inf_IN; + gCurrentTask->td_LineNumber = inf->inf_LineNumber; + gCurrentTask->td_SourceNum = inf->inf_SourceNum; +/* Copy TIB plus any NUL terminator into saved area. */ + if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) + { + pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 ); + } + + } +DBUG(("ffPopInputStream: return = 0x%x\n", Result )); + + return Result; +} + +/*************************************************************** +** Convert file pointer to value consistent with SOURCE-ID. +***************************************************************/ +cell_t ffConvertStreamToSourceID( FileStream *Stream ) +{ + cell_t Result; + if(Stream == PF_STDIN) + { + Result = 0; + } + else if(Stream == NULL) + { + Result = -1; + } + else + { + Result = (cell_t) Stream; + } + return Result; +} + +/*************************************************************** +** Convert file pointer to value consistent with SOURCE-ID. +***************************************************************/ +FileStream * ffConvertSourceIDToStream( cell_t id ) +{ + FileStream *stream; + + if( id == 0 ) + { + stream = PF_STDIN; + } + else if( id == -1 ) + { + stream = NULL; + } + else + { + stream = (FileStream *) id; + } + return stream; +} + +/************************************************************** +** Receive line from input stream. +** Return length, or -1 for EOF. +*/ +#define BACKSPACE (8) +static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream ) +{ + int c; + int len; + char *p; + static int lastChar = 0; + int done = 0; + +DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream )); + p = buffer; + len = 0; + while( (len < maxChars) && !done ) + { + c = sdInputChar(stream); + switch(c) + { + case EOF: + DBUG(("EOF\n")); + done = 1; + if( len <= 0 ) len = -1; + break; + + case '\n': + DBUGX(("EOL=\\n\n")); + if( lastChar != '\r' ) done = 1; + break; + + case '\r': + DBUGX(("EOL=\\r\n")); + done = 1; + break; + + default: + *p++ = (char) c; + len++; + break; + } + lastChar = c; + } + +/* NUL terminate line to simplify printing when debugging. */ + if( (len >= 0) && (len < maxChars) ) p[len] = '\0'; + + return len; +} + +/************************************************************** +** ( -- , fill Source from current stream ) +** Return 1 if successful, 0 for EOF, or a negative error. +*/ +cell_t ffRefill( void ) +{ + cell_t Num; + cell_t Result = 1; + +/* reset >IN for parser */ + gCurrentTask->td_IN = 0; + +/* get line from current stream */ + if( gCurrentTask->td_InputStream == PF_STDIN ) + { + /* ACCEPT is deferred so we call it through the dictionary. */ + PUSH_DATA_STACK( gCurrentTask->td_SourcePtr ); + PUSH_DATA_STACK( TIB_SIZE ); + pfCatch( gAcceptP_XT ); + Num = POP_DATA_STACK; + if( Num < 0 ) + { + Result = Num; + goto error; + } + } + else + { + Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE, + gCurrentTask->td_InputStream ); + if( Num == EOF ) + { + Result = 0; + Num = 0; + } + } + + gCurrentTask->td_SourceNum = Num; + gCurrentTask->td_LineNumber++; /* Bump for include. */ + +/* echo input if requested */ + if( gVarEcho && ( Num > 0)) + { + ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum ); + EMIT_CR; + } + +error: + return Result; +} diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h index 8f27015..3ff831c 100644 --- a/csrc/pfcompil.h +++ b/csrc/pfcompil.h @@ -1,73 +1,73 @@ -/* @(#) 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 */ +/* @(#) pfcompil.h 96/12/18 1.11 */ + +#ifndef _pforth_compile_h +#define _pforth_compile_h + +/*************************************************************** +** Include file for PForth Compiler +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +Err ffPushInputStream( FileStream *InputFile ); +ExecToken NameToToken( const ForthString *NFA ); +FileStream * ffConvertSourceIDToStream( cell_t id ); +FileStream *ffPopInputStream( void ); +cell_t ffConvertStreamToSourceID( FileStream *Stream ); +cell_t ffFind( const ForthString *WordName, ExecToken *pXT ); +cell_t ffFindC( const char *WordName, ExecToken *pXT ); +cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ); +cell_t ffNumberQ( const char *FWord, cell_t *Num ); +cell_t ffRefill( void ); +cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); +cell_t *NameToCode( ForthString *NFA ); +PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ); +char *ffWord( char c ); +const ForthString *NameToPrevious( const ForthString *NFA ); +cell_t FindSpecialCFAs( void ); +cell_t FindSpecialXTs( void ); +cell_t NotCompiled( const char *FunctionName ); +void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags ); +void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags ); +void ff2Literal( cell_t dHi, cell_t dLo ); +void ffALiteral( cell_t Num ); +void ffColon( void ); +void ffCreate( void ); +void ffCreateSecondaryHeader( const ForthStringPtr FName); +void ffDefer( void ); +void ffFinishSecondary( void ); +void ffLiteral( cell_t Num ); +void ffStringCreate( ForthStringPtr FName); +void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ); +void pfHandleIncludeError( void ); + +ThrowCode ffSemiColon( void ); +ThrowCode ffOK( void ); +ThrowCode ffInterpret( void ); +ThrowCode ffOuterInterpreterLoop( void ); +ThrowCode ffIncludeFile( FileStream *InputFile ); + +#ifdef PF_SUPPORT_FP +void ffFPLiteral( PF_FLOAT fnum ); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_compile_h */ diff --git a/csrc/pfcustom.c b/csrc/pfcustom.c index 1cacea2..9905348 100644 --- a/csrc/pfcustom.c +++ b/csrc/pfcustom.c @@ -1,121 +1,121 @@ -/* @(#) 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 */ - +/* @(#) pfcustom.c 98/01/26 1.3 */ + +#ifndef PF_USER_CUSTOM + +/*************************************************************** +** Call Custom Functions for pForth +** +** Create a file similar to this and compile it into pForth +** by setting -DPF_USER_CUSTOM="mycustom.c" +** +** Using this, you could, for example, call X11 from Forth. +** See "pf_cglue.c" for more information. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + + +#include "pf_all.h" + +static cell_t CTest0( cell_t Val ); +static void CTest1( cell_t Val1, cell_t Val2 ); + +/**************************************************************** +** Step 1: Put your own special glue routines here +** or link them in from another file or library. +****************************************************************/ +static cell_t CTest0( cell_t Val ) +{ + MSG_NUM_D("CTest0: Val = ", Val); + return Val+1; +} + +static void CTest1( cell_t Val1, cell_t Val2 ) +{ + + MSG("CTest1: Val1 = "); ffDot(Val1); + MSG_NUM_D(", Val2 = ", Val2); +} + +/**************************************************************** +** Step 2: Create CustomFunctionTable. +** Do not change the name of CustomFunctionTable! +** It is used by the pForth kernel. +****************************************************************/ + +#ifdef PF_NO_GLOBAL_INIT +/****************** +** If your loader does not support global initialization, then you +** must define PF_NO_GLOBAL_INIT and provide a function to fill +** the table. Some embedded system loaders require this! +** Do not change the name of LoadCustomFunctionTable()! +** It is called by the pForth kernel. +*/ +#define NUM_CUSTOM_FUNCTIONS (2) +CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS]; + +Err LoadCustomFunctionTable( void ) +{ + CustomFunctionTable[0] = CTest0; + CustomFunctionTable[1] = CTest1; + return 0; +} + +#else +/****************** +** If your loader supports global initialization (most do.) then just +** create the table like this. +*/ +CFunc0 CustomFunctionTable[] = +{ + (CFunc0) CTest0, + (CFunc0) CTest1 +}; +#endif + +/**************************************************************** +** Step 3: Add custom functions to the dictionary. +** Do not change the name of CompileCustomFunctions! +** It is called by the pForth kernel. +****************************************************************/ + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) +Err CompileCustomFunctions( void ) +{ + Err err; + int i = 0; +/* Compile Forth words that call your custom functions. +** Make sure order of functions matches that in LoadCustomFunctionTable(). +** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams +*/ + err = CreateGlueToC( "CTEST0", i++, C_RETURNS_VALUE, 1 ); + if( err < 0 ) return err; + err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 ); + if( err < 0 ) return err; + + return 0; +} +#else +Err CompileCustomFunctions( void ) { return 0; } +#endif + +/**************************************************************** +** Step 4: Recompile using compiler option PF_USER_CUSTOM +** and link with your code. +** Then rebuild the Forth using "pforth -i system.fth" +** Test: 10 Ctest0 ( should print message then '11' ) +****************************************************************/ + +#endif /* PF_USER_CUSTOM */ + diff --git a/csrc/pfinnrfp.h b/csrc/pfinnrfp.h index e6c0104..b74b045 100644 --- a/csrc/pfinnrfp.h +++ b/csrc/pfinnrfp.h @@ -1,336 +1,336 @@ -/* @(#) 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 +/* @(#) pfinnrfp.h 98/02/26 1.4 */ +/*************************************************************** +** Compile FP routines. +** This file is included from "pf_inner.c" +** +** These routines could be left out of an execute only version. +** +** Author: Darren Gibbs, Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + +#ifdef PF_SUPPORT_FP + +#define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*4.0) + + case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */ + PUSH_FP_TOS; + Scratch = M_POP; /* dlo */ + DBUG(("dlo = 0x%8x , ", Scratch)); + DBUG(("dhi = 0x%8x\n", TOS)); + + if( ((TOS == 0) && (Scratch >= 0)) || + ((TOS == -1) && (Scratch < 0))) + { + /* <= 32 bit precision. */ + FP_TOS = ((PF_FLOAT) Scratch); /* Convert dlo and push on FP stack. */ + } + else /* > 32 bit precision. */ + { + fpTemp = ((PF_FLOAT) TOS); /* dhi */ + fpTemp *= FP_DHI1; + fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */ + FP_TOS = fpTemp + fpScratch; + } + M_DROP; + /* printf("d2f = %g\n", FP_TOS); */ + break; + + case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_CODE_DIC(TOS) ) + { + WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS ); + } + else + { + *((PF_FLOAT *) TOS) = FP_TOS; + } +#else + *((PF_FLOAT *) TOS) = FP_TOS; +#endif + M_FP_DROP; /* drop FP value */ + M_DROP; /* drop addr */ + break; + + case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */ + FP_TOS = M_FP_POP * FP_TOS; + break; + + case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */ + FP_TOS = M_FP_POP + FP_TOS; + break; + + case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */ + FP_TOS = M_FP_POP - FP_TOS; + break; + + case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */ + FP_TOS = M_FP_POP / FP_TOS; + break; + + case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */ + PUSH_TOS; + TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */ + PUSH_TOS; + TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */ + PUSH_TOS; + TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */ + /* printf("f2d = %g\n", FP_TOS); */ + { + ucell_t dlo; + cell_t dhi; + int ifNeg; + /* Convert absolute value, then negate D if negative. */ + PUSH_TOS; /* Save old TOS */ + fpTemp = FP_TOS; + M_FP_DROP; + ifNeg = (fpTemp < 0.0); + if( ifNeg ) + { + fpTemp = 0.0 - fpTemp; + } + fpScratch = fpTemp / FP_DHI1; + /* printf("f2d - fpScratch = %g\n", fpScratch); */ + dhi = (cell_t) fpScratch; /* dhi */ + fpScratch = ((PF_FLOAT) dhi) * FP_DHI1; + /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */ + + fpTemp = fpTemp - fpScratch; /* Remainder */ + dlo = (ucell_t) fpTemp; + /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */ + if( ifNeg ) + { + dlo = 0 - dlo; + dhi = 0 - dhi - 1; + } + /* Push onto stack. */ + TOS = dlo; + PUSH_TOS; + TOS = dhi; + } + break; + + case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */ + PUSH_FP_TOS; +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_CODE_DIC(TOS) ) + { + FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS ); + } + else + { + FP_TOS = *((PF_FLOAT *) TOS); + } +#else + FP_TOS = *((PF_FLOAT *) TOS); +#endif + M_DROP; + break; + + case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */ + PUSH_TOS; + /* Add 1 to account for FP_TOS in cached in register. */ + TOS = (( M_FP_SPZERO - FP_STKPTR) + 1); + break; + + case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */ + M_FP_DROP; + break; + + case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */ + PUSH_FP_TOS; + break; + + case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */ + TOS = TOS + sizeof(PF_FLOAT); + break; + + case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */ + TOS = TOS * sizeof(PF_FLOAT); + break; + + case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_floor( FP_TOS ); + break; + + case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */ + fpScratch = M_FP_POP; + FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ; + break; + + case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */ + fpScratch = M_FP_POP; + FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ; + break; + + case ID_FP_FNEGATE: + FP_TOS = -FP_TOS; + break; + + case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */ + PUSH_FP_TOS; + FP_TOS = M_FP_STACK(1); + break; + + case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */ + fpScratch = M_FP_POP; /* r2 */ + fpTemp = M_FP_POP; /* r1 */ + M_FP_PUSH( fpScratch ); /* r2 */ + PUSH_FP_TOS; /* r3 */ + FP_TOS = fpTemp; /* r1 */ + break; + + case ID_FP_FROUND: + ERR("\nID_FP_FROUND - Not Yet!! FIXME\n"); + break; + + case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */ + fpScratch = FP_TOS; + FP_TOS = *FP_STKPTR; + *FP_STKPTR = fpScratch; + break; + + case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */ + fpScratch = M_FP_POP; + FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS); + break; + + case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS ); + break; + + case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_acos( FP_TOS ); + break; + + case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */ + /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1))); + break; + + case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS); + break; + + case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_asin( FP_TOS ); + break; + + case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */ + /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1))); + break; + + case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_atan( FP_TOS ); + break; + + case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */ + fpTemp = M_FP_POP; + FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS ); + break; + + case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS))); + break; + + case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_cos( FP_TOS ); + break; + + case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS ); + break; + +#ifndef PF_NO_SHELL + case ID_FP_FLITERAL: + ffFPLiteral( FP_TOS ); + M_FP_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_FP_FLITERAL_P: + PUSH_FP_TOS; +#if 0 +/* Some wimpy compilers can't handle this! */ + FP_TOS = *(((PF_FLOAT *)InsPtr)++); +#else + { + PF_FLOAT *fptr; + fptr = (PF_FLOAT *)InsPtr; + FP_TOS = READ_FLOAT_DIC( fptr++ ); + InsPtr = (cell_t *) fptr; + } +#endif + endcase; + + case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS); + break; + + case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0); + break; + + case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_log10( FP_TOS ); + break; + + case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sin( FP_TOS ); + break; + + case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */ + M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS)); + FP_TOS = (PF_FLOAT) fp_cos(FP_TOS); + break; + + case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS ); + break; + + case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS ); + break; + + case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_tan( FP_TOS ); + break; + + case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS ); + break; + + case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */ + PUSH_FP_TOS; /* push cached floats into RAM */ + FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */ + M_DROP; + break; + + +#endif diff --git a/csrc/pforth.h b/csrc/pforth.h index 70a700a..cd74336 100644 --- a/csrc/pforth.h +++ b/csrc/pforth.h @@ -1,93 +1,93 @@ -/* @(#) 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 -/* 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 */ +/* @(#) 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 +/* Integer types for Forth cells, signed and unsigned: */ +typedef intptr_t cell_t; +typedef uintptr_t ucell_t; + +typedef ucell_t ExecToken; /* Execution Token */ +typedef cell_t ThrowCode; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Main entry point to pForth. */ +cell_t pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit ); + +/* Turn off messages. */ +void pfSetQuiet( cell_t IfQuiet ); + +/* Query message status. */ +cell_t pfQueryQuiet( void ); + +/* Send a message using low level I/O of pForth */ +void pfMessage( const char *CString ); + +/* Create a task used to maintain context of execution. */ +PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth ); + +/* Establish this task as the current task. */ +void pfSetCurrentTask( PForthTask task ); + +/* Delete task created by pfCreateTask */ +void pfDeleteTask( PForthTask task ); + +/* Build a dictionary with all the basic kernel words. */ +PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ); + +/* Create an empty dictionary. */ +PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize ); + +/* Load dictionary from a file. */ +PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); + +/* Load dictionary from static array in "pfdicdat.h". */ +PForthDictionary pfLoadStaticDictionary( void ); + +/* Delete dictionary data. */ +void pfDeleteDictionary( PForthDictionary dict ); + +/* Execute the pForth interpreter. Yes, QUIT is an odd name but it has historical meaning. */ +ThrowCode pfQuit( void ); + +/* Execute a single execution token in the current task and return 0 or an error code. */ +int pfCatch( ExecToken XT ); + +/* Include the given pForth source code file. */ +ThrowCode pfIncludeFile( const char *FileName ); + +/* Execute a Forth word by name. */ +ThrowCode pfExecIfDefined( const char *CString ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_h */ diff --git a/csrc/posix/pf_io_posix.c b/csrc/posix/pf_io_posix.c index b456788..39ca2a9 100644 --- a/csrc/posix/pf_io_posix.c +++ b/csrc/posix/pf_io_posix.c @@ -1,141 +1,141 @@ -/* $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 -#include -#ifdef sun -#include /* Needed on Solaris for uint32_t in termio.h */ -#endif -#include -#include - -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$ */ +/*************************************************************** +** 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 +#include +#ifdef sun +#include /* Needed on Solaris for uint32_t in termio.h */ +#endif +#include +#include + +static struct termios save_termios; +static int stdin_is_tty; + +/* poll() is broken in Mac OS X Tiger OS so use select() instead. */ +#ifndef PF_USE_SELECT +#define PF_USE_SELECT (1) +#endif + +/* Default portable terminal I/O. */ +int sdTerminalOut( char c ) +{ + return putchar(c); +} + +int sdTerminalEcho( char c ) +{ + putchar(c); + return 0; +} + +int sdTerminalIn( void ) +{ + return getchar(); +} + +int sdTerminalFlush( void ) +{ +#ifdef PF_NO_FILEIO + return -1; +#else + return fflush(PF_STDOUT); +#endif +} + +/****************************************************/ +int sdQueryTerminal( void ) +{ +#if PF_USE_SELECT + int select_retval; + fd_set readfds; + struct timeval tv; + FD_ZERO(&readfds); + FD_SET(STDIN_FILENO, &readfds); + /* Set timeout to zero so that we just poll and return. */ + tv.tv_sec = 0; + tv.tv_usec = 0; + select_retval = select(STDIN_FILENO+1, &readfds, NULL, NULL, &tv); + if (select_retval < 0) + { + perror("sdTerminalInit: select"); + } + return FD_ISSET(STDIN_FILENO,&readfds) ? FTRUE : FFALSE; + +#else + int result; + struct pollfd pfd = { 0 }; + sdTerminalFlush(); + pfd.fd = STDIN_FILENO; + pfd.events = POLLIN; + result = poll( &pfd, 1, 0 ); + /* On a Mac it may set revents to POLLNVAL because poll() is broken on Tiger. */ + if( pfd.revents & POLLNVAL ) + { + PRT(("sdQueryTerminal: poll got POLLNVAL, stdin not open\n")); + return FFALSE; + } + else + { + return (pfd.revents & POLLIN) ? FTRUE : FFALSE; + } +#endif +} + +/****************************************************/ +void sdTerminalInit(void) +{ + struct termios term; + + stdin_is_tty = isatty(STDIN_FILENO); + if (stdin_is_tty) + { +/* Get current terminal attributes and save them so we can restore them. */ + tcgetattr(STDIN_FILENO, &term); + save_termios = term; + +/* ICANON says to wait upon read until a character is received, + * and then to return it immediately (or soon enough....) + * ECHOCTL says not to echo backspaces and other control chars as ^H */ + term.c_lflag &= ~( ECHO | ECHONL | ECHOCTL | ICANON ); + term.c_cc[VTIME] = 0; + term.c_cc[VMIN] = 1; + if( tcsetattr(STDIN_FILENO, TCSANOW, &term) < 0 ) + { + perror("sdTerminalInit: tcsetattr"); + } + } +} + +/****************************************************/ +void sdTerminalTerm(void) +{ + if (stdin_is_tty) + { + tcsetattr(STDIN_FILENO, TCSANOW, &save_termios); + } +} diff --git a/csrc/stdio/pf_io_stdio.c b/csrc/stdio/pf_io_stdio.c index 75decfc..6d70a6b 100644 --- a/csrc/stdio/pf_io_stdio.c +++ b/csrc/stdio/pf_io_stdio.c @@ -1,57 +1,57 @@ -/* $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$ */ +/*************************************************************** +** I/O subsystem for PForth for common systems. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 941004 PLB Extracted IO calls from pforth_main.c +***************************************************************/ + +#include "../pf_all.h" + +/* Default portable terminal I/O. */ +int sdTerminalOut( char c ) +{ + return putchar(c); +} +/* We don't need to echo because getchar() echos. */ +int sdTerminalEcho( char c ) +{ + return 0; +} +int sdTerminalIn( void ) +{ + return getchar(); +} +int sdQueryTerminal( void ) +{ + return 0; +} + +int sdTerminalFlush( void ) +{ +#ifdef PF_NO_FILEIO + return -1; +#else + return fflush(PF_STDOUT); +#endif +} + +void sdTerminalInit( void ) +{ +} +void sdTerminalTerm( void ) +{ +} + diff --git a/csrc/win32/pf_io_win32.c b/csrc/win32/pf_io_win32.c index 6fd93e3..2d75822 100644 --- a/csrc/win32/pf_io_win32.c +++ b/csrc/win32/pf_io_win32.c @@ -1,72 +1,72 @@ -/* $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 - -/* 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$ */ +/*************************************************************** +** 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 + +/* Use console mode I/O so that KEY and ?TERMINAL will work. */ +#if defined(WIN32) || defined(__NT__) +int sdTerminalOut( char c ) +{ +#if defined(__WATCOMC__) + return putch((char)(c)); +#else + return _putch((char)(c)); +#endif +} + +/* Needed cuz _getch() does not echo. */ +int sdTerminalEcho( char c ) +{ +#if defined(__WATCOMC__) + return putch((char)(c)); +#else + return _putch((char)(c)); +#endif +} + +int sdTerminalIn( void ) +{ + return _getch(); +} + +int sdQueryTerminal( void ) +{ + return _kbhit(); +} + +int sdTerminalFlush( void ) +{ +#ifdef PF_NO_FILEIO + return -1; +#else + return fflush(PF_STDOUT); +#endif +} + +void sdTerminalInit( void ) +{ +} + +void sdTerminalTerm( void ) +{ +} +#endif diff --git a/csrc/win32_console/pf_io_win32_console.c b/csrc/win32_console/pf_io_win32_console.c index a081812..ced47a8 100644 --- a/csrc/win32_console/pf_io_win32_console.c +++ b/csrc/win32_console/pf_io_win32_console.c @@ -1,231 +1,231 @@ -/* $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 - -#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 +/* $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 + +#define ASCII_ESCAPE (0x1B) + +static HANDLE sConsoleHandle = INVALID_HANDLE_VALUE; +static int sIsConsoleValid = FALSE; + +typedef enum ConsoleState_e +{ + SDCONSOLE_STATE_IDLE = 0, + SDCONSOLE_STATE_GOT_ESCAPE, + SDCONSOLE_STATE_GOT_BRACKET + +} ConsoleState; + +static int sConsoleState = SDCONSOLE_STATE_IDLE; +static int sParam1 = 0; +static CONSOLE_SCREEN_BUFFER_INFO sScreenInfo; + +/******************************************************************/ +static void sdConsoleEmit( char c ) +{ + /* Write a WCHAR in case we have compiled with Unicode support. + * Otherwise we will see '?' printed.*/ + WCHAR wc = (WCHAR) c; + DWORD count; + if( sIsConsoleValid ) + { + WriteConsoleW(sConsoleHandle, &wc, 1, &count, NULL ); + } + else + { + /* This will get called if we are redirecting to a file.*/ + WriteFile(sConsoleHandle, &c, 1, &count, NULL ); + } +} + +/******************************************************************/ +static void sdClearScreen( void ) +{ + if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) + { + COORD XY; + int numNeeded; + DWORD count; + XY.X = 0; + XY.Y = sScreenInfo.srWindow.Top; + numNeeded = sScreenInfo.dwSize.X * (sScreenInfo.srWindow.Bottom - sScreenInfo.srWindow.Top + 1); + FillConsoleOutputCharacter( + sConsoleHandle, ' ', numNeeded, XY, &count ); + SetConsoleCursorPosition( sConsoleHandle, XY ); + } +} + +/******************************************************************/ +static void sdEraseEOL( void ) +{ + if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) + { + COORD savedXY; + int numNeeded; + DWORD count; + savedXY.X = sScreenInfo.dwCursorPosition.X; + savedXY.Y = sScreenInfo.dwCursorPosition.Y; + numNeeded = sScreenInfo.dwSize.X - savedXY.X; + FillConsoleOutputCharacter( + sConsoleHandle, ' ', numNeeded, savedXY, &count ); + } +} + +/******************************************************************/ +static void sdCursorBack( int dx ) +{ + if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) + { + COORD XY; + XY.X = sScreenInfo.dwCursorPosition.X; + XY.Y = sScreenInfo.dwCursorPosition.Y; + XY.X -= dx; + if( XY.X < 0 ) XY.X = 0; + SetConsoleCursorPosition( sConsoleHandle, XY ); + } +} +/******************************************************************/ +static void sdCursorForward( int dx ) +{ + if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) + { + COORD XY; + int width = sScreenInfo.dwSize.X; + XY.X = sScreenInfo.dwCursorPosition.X; + XY.Y = sScreenInfo.dwCursorPosition.Y; + XY.X += dx; + if( XY.X > width ) XY.X = width; + SetConsoleCursorPosition( sConsoleHandle, XY ); + } +} + +/******************************************************************/ +/* Use console mode I/O so that KEY and ?TERMINAL will work. + * Parse ANSI escape sequences and call the appropriate cursor + * control functions. + */ +int sdTerminalOut( char c ) +{ + switch( sConsoleState ) + { + case SDCONSOLE_STATE_IDLE: + switch( c ) + { + case ASCII_ESCAPE: + sConsoleState = SDCONSOLE_STATE_GOT_ESCAPE; + break; + default: + sdConsoleEmit( c ); + } + break; + + case SDCONSOLE_STATE_GOT_ESCAPE: + switch( c ) + { + case '[': + sConsoleState = SDCONSOLE_STATE_GOT_BRACKET; + sParam1 = 0; + break; + default: + sConsoleState = SDCONSOLE_STATE_IDLE; + sdConsoleEmit( c ); + } + break; + + case SDCONSOLE_STATE_GOT_BRACKET: + if( (c >= '0') && (c <= '9') ) + { + sParam1 = (sParam1 * 10) + (c - '0'); + } + else + { + sConsoleState = SDCONSOLE_STATE_IDLE; + if( c == 'K') + { + sdEraseEOL(); + } + else if( c == 'D' ) + { + sdCursorBack( sParam1 ); + } + else if( c == 'C' ) + { + sdCursorForward( sParam1 ); + } + else if( (c == 'J') && (sParam1 == 2) ) + { + sdClearScreen(); + } + } + break; + } + return 0; +} + +/* Needed cuz _getch() does not echo. */ +int sdTerminalEcho( char c ) +{ + sdConsoleEmit((char)(c)); + return 0; +} + +int sdTerminalIn( void ) +{ + return _getch(); +} + +int sdQueryTerminal( void ) +{ + return _kbhit(); +} + +int sdTerminalFlush( void ) +{ +#ifdef PF_NO_FILEIO + return -1; +#else + return fflush(PF_STDOUT); +#endif +} + +void sdTerminalInit( void ) +{ + DWORD mode = 0; + sConsoleHandle = GetStdHandle( STD_OUTPUT_HANDLE ); + if( GetConsoleMode( sConsoleHandle, &mode ) ) + { + /*printf("GetConsoleMode() mode is 0x%08X\n", mode );*/ + sIsConsoleValid = TRUE; + } + else + { + /*printf("GetConsoleMode() failed\n", mode );*/ + sIsConsoleValid = FALSE; + } +} + +void sdTerminalTerm( void ) +{ +} +#endif diff --git a/fth/ansilocs.fth b/fth/ansilocs.fth index 29d9075..33c0c71 100644 --- a/fth/ansilocs.fth +++ b/fth/ansilocs.fth @@ -1,203 +1,203 @@ -\ @(#) 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 ) - , - immediate - DOES> - state @ - IF - [compile] aliteral - compile @ - ELSE - @ - THEN -; - -: TO ( val -- ) - 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 -- ) - 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 +\ @(#) 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 ) + , + immediate + DOES> + state @ + IF + [compile] aliteral + compile @ + ELSE + @ + THEN +; + +: TO ( val -- ) + 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 -- ) + bl word + lv.match + IF ( -- index ) + 1+ \ adjust for optimised (local!), LocalsPtr points above vars + [compile] literal compile (local+!) + ELSE + find + 1 = 0= abort" +-> before non-local or non-value" + >body \ point to data + state @ + IF \ compiling ( -- pfa ) + [compile] aliteral + compile +! + ELSE \ executing ( -- val pfa ) + +! + THEN + THEN +; immediate + +: : lv.setup : ; +: ; lv.finish [compile] ; ; immediate +: exit lv.cleanup compile exit ; immediate +: does> lv.finish [compile] does> ; immediate + +privatize diff --git a/fth/bench.fth b/fth/bench.fth index bd5c430..40262ec 100644 --- a/fth/bench.fth +++ b/fth/bench.fth @@ -1,198 +1,198 @@ -\ @(#) 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 - -: ( --- #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 swap drop - LOOP . ." primes " CR ; - -: SIEVE50 ." 50 iterations " CR 0 50 0 - DO 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 +\ @(#) 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 + +: ( --- #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 swap drop + LOOP . ." primes " CR ; + +: SIEVE50 ." 50 iterations " CR 0 50 0 + DO swap drop + LOOP . ." primes " CR ; + +\ 10 iterations +\ 21.5 sec Amiga Multi-Forth Indirect Threaded +\ 8.82 sec Amiga 1000 running JForth +\ ~5 sec SGI Indy running pForthV9 diff --git a/fth/c_struct.fth b/fth/c_struct.fth index 5898bf8..78cf163 100644 --- a/fth/c_struct.fth +++ b/fth/c_struct.fth @@ -1,242 +1,242 @@ -\ @(#) 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_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 -- , 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 -- value , fetch value from member ) - ob.stats? - (s@) -; immediate - - - -exists? F* [IF] -\ 951112 Floating Point support -: FLPT ( -- , 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 -- , 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 -- 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] +\ @(#) 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_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 -- , 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 -- value , fetch value from member ) + ob.stats? + (s@) +; immediate + + + +exists? F* [IF] +\ 951112 Floating Point support +: FLPT ( -- , 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 -- , 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 -- value , fetch value from member ) + ob.stats? + 1 floats <> abort" FS@ with non-float!" + state @ + IF + [compile] literal + compile (s+f@) + ELSE (s+f@) + THEN +; immediate +[THEN] + +0 [IF] +:struct mapper + long map_l1 + long map_l2 + aptr map_a1 + rptr map_r1 + flpt map_f1 + short map_s1 + ushort map_s2 + byte map_b1 + ubyte map_b2 +;struct +mapper map1 + +: TT + -500 map1 s! map_s1 + map1 s@ map_s1 -500 - abort" map_s1 failed!" + -500 map1 s! map_s2 + map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" + -89 map1 s! map_b1 + map1 s@ map_b1 -89 - abort" map_s1 failed!" + here map1 s! map_r1 + map1 s@ map_r1 here - abort" map_r1 failed!" + -89 map1 s! map_b2 + map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" + 23.45 map1 fs! map_f1 + map1 fs@ map_f1 f. ." =?= 23.45" cr +; +." Testing c_struct.fth" cr +TT +[THEN] diff --git a/fth/case.fth b/fth/case.fth index ab71641..830dc83 100644 --- a/fth/case.fth +++ b/fth/case.fth @@ -1,78 +1,78 @@ -\ @(#) 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 - +\ @(#) case.fth 98/01/26 1.2 +\ CASE Statement +\ +\ This definition is based upon Wil Baden's assertion that +\ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ MOD: PLB 6/24/91 Check for missing ENDOF +\ MOD: PLB 8/7/91 Add ?OF and RANGEOF +\ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth. + +anew TASK-CASE + +variable CASE-DEPTH +variable OF-DEPTH + +: CASE ( n -- , start case statement ) ( -c- case-depth ) + ?comp + of-depth @ 0 of-depth ! \ 11/2/99 + case-depth @ 0 case-depth ! ( allow nesting ) +; IMMEDIATE + +: ?OF ( n flag -- | n , doit if true ) ( -c- addr ) + [compile] IF + compile drop + 1 case-depth +! + 1 of-depth +! +; IMMEDIATE + +: OF ( n t -- | n , doit if match ) ( -c- addr ) + ?comp + compile over compile = + [compile] ?OF +; IMMEDIATE + +: (RANGEOF?) ( n lo hi -- | n flag ) + >r over ( n lo n ) <= + IF + dup r> ( n n hi ) <= + ELSE + rdrop false + THEN +; + +: RANGEOF ( n lo hi -- | n , doit if within ) ( -c- addr ) + compile (rangeof?) + [compile] ?OF +; IMMEDIATE + +: ENDOF ( -- ) ( addr -c- addr' ) + [compile] ELSE + -1 of-depth +! +; IMMEDIATE + +: ENDCASE ( n -- ) ( old-case-depth addr' addr' ??? -- ) + of-depth @ + IF >newline ." Missing ENDOF in CASE!" cr abort + THEN +\ + compile drop + case-depth @ 0 + ?DO [compile] THEN + LOOP + case-depth ! + of-depth ! +; IMMEDIATE + diff --git a/fth/condcomp.fth b/fth/condcomp.fth index d312ca1..dc65c6b 100644 --- a/fth/condcomp.fth +++ b/fth/condcomp.fth @@ -1,50 +1,50 @@ -\ @(#) 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? ( -- flag , true if defined ) - bl word find - swap drop -; immediate +\ @(#) 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? ( -- flag , true if defined ) + bl word find + swap drop +; immediate diff --git a/fth/coretest.fth b/fth/coretest.fth index c91b27c..53fc24d 100644 --- a/fth/coretest.fth +++ b/fth/coretest.fth @@ -1,999 +1,999 @@ -\ 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 -1S CONSTANT - -{ 0 0= -> } -{ 1 0= -> } -{ 2 0= -> } -{ -1 0= -> } -{ MAX-UINT 0= -> } -{ MIN-INT 0= -> } -{ MAX-INT 0= -> } - -{ 0 0 = -> } -{ 1 1 = -> } -{ -1 -1 = -> } -{ 1 0 = -> } -{ -1 0 = -> } -{ 0 1 = -> } -{ 0 -1 = -> } - -{ 0 0< -> } -{ -1 0< -> } -{ MIN-INT 0< -> } -{ 1 0< -> } -{ MAX-INT 0< -> } - -{ 0 1 < -> } -{ 1 2 < -> } -{ -1 0 < -> } -{ -1 1 < -> } -{ MIN-INT 0 < -> } -{ MIN-INT MAX-INT < -> } -{ 0 MAX-INT < -> } -{ 0 0 < -> } -{ 1 1 < -> } -{ 1 0 < -> } -{ 2 1 < -> } -{ 0 -1 < -> } -{ 1 -1 < -> } -{ 0 MIN-INT < -> } -{ MAX-INT MIN-INT < -> } -{ MAX-INT 0 < -> } - -{ 0 1 > -> } -{ 1 2 > -> } -{ -1 0 > -> } -{ -1 1 > -> } -{ MIN-INT 0 > -> } -{ MIN-INT MAX-INT > -> } -{ 0 MAX-INT > -> } -{ 0 0 > -> } -{ 1 1 > -> } -{ 1 0 > -> } -{ 2 1 > -> } -{ 0 -1 > -> } -{ 1 -1 > -> } -{ 0 MIN-INT > -> } -{ MAX-INT MIN-INT > -> } -{ MAX-INT 0 > -> } - -{ 0 1 U< -> } -{ 1 2 U< -> } -{ 0 MID-UINT U< -> } -{ 0 MAX-UINT U< -> } -{ MID-UINT MAX-UINT U< -> } -{ 0 0 U< -> } -{ 1 1 U< -> } -{ 1 0 U< -> } -{ 2 1 U< -> } -{ MID-UINT 0 U< -> } -{ MAX-UINT 0 U< -> } -{ MAX-UINT MID-UINT U< -> } - -{ 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< -> } \ 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< -> } \ 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< -> } \ 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 < -> } -{ 1 CHARS 1 CELLS > -> } -( TBD: HOW TO FIND NUMBER OF BITS? ) - -( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) -{ 1 CELLS 1 < -> } -{ 1 CELLS 1 CHARS MOD -> 0 } -{ 1S BITS 10 < -> } - -{ 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= -> } - -\ ------------------------------------------------------------------------ -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 -> } - -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 UNLOOP EXIT THEN - SWAP CHAR+ SWAP CHAR+ - LOOP - THEN - 2DROP \ IF WE GET HERE, STRINGS MATCH - ELSE - R> DROP 2DROP \ LENGTHS MISMATCH - THEN ; - -: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; -{ GP1 -> } - -: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; -{ GP2 -> } - -: GP3 <# 1 0 # # #> S" 01" S= ; -{ GP3 -> } - -: GP4 <# 1 0 #S #> S" 1" S= ; -{ GP4 -> } - -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 @ - 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 -> } - -: 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 -> } - -: GP7 - BASE @ >R MAX-BASE BASE ! - - 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 -> } - -\ >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 } - - +\ 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 +1S CONSTANT + +{ 0 0= -> } +{ 1 0= -> } +{ 2 0= -> } +{ -1 0= -> } +{ MAX-UINT 0= -> } +{ MIN-INT 0= -> } +{ MAX-INT 0= -> } + +{ 0 0 = -> } +{ 1 1 = -> } +{ -1 -1 = -> } +{ 1 0 = -> } +{ -1 0 = -> } +{ 0 1 = -> } +{ 0 -1 = -> } + +{ 0 0< -> } +{ -1 0< -> } +{ MIN-INT 0< -> } +{ 1 0< -> } +{ MAX-INT 0< -> } + +{ 0 1 < -> } +{ 1 2 < -> } +{ -1 0 < -> } +{ -1 1 < -> } +{ MIN-INT 0 < -> } +{ MIN-INT MAX-INT < -> } +{ 0 MAX-INT < -> } +{ 0 0 < -> } +{ 1 1 < -> } +{ 1 0 < -> } +{ 2 1 < -> } +{ 0 -1 < -> } +{ 1 -1 < -> } +{ 0 MIN-INT < -> } +{ MAX-INT MIN-INT < -> } +{ MAX-INT 0 < -> } + +{ 0 1 > -> } +{ 1 2 > -> } +{ -1 0 > -> } +{ -1 1 > -> } +{ MIN-INT 0 > -> } +{ MIN-INT MAX-INT > -> } +{ 0 MAX-INT > -> } +{ 0 0 > -> } +{ 1 1 > -> } +{ 1 0 > -> } +{ 2 1 > -> } +{ 0 -1 > -> } +{ 1 -1 > -> } +{ 0 MIN-INT > -> } +{ MAX-INT MIN-INT > -> } +{ MAX-INT 0 > -> } + +{ 0 1 U< -> } +{ 1 2 U< -> } +{ 0 MID-UINT U< -> } +{ 0 MAX-UINT U< -> } +{ MID-UINT MAX-UINT U< -> } +{ 0 0 U< -> } +{ 1 1 U< -> } +{ 1 0 U< -> } +{ 2 1 U< -> } +{ MID-UINT 0 U< -> } +{ MAX-UINT 0 U< -> } +{ MAX-UINT MID-UINT U< -> } + +{ 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< -> } \ 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< -> } \ 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< -> } \ 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 < -> } +{ 1 CHARS 1 CELLS > -> } +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +{ 1 CELLS 1 < -> } +{ 1 CELLS 1 CHARS MOD -> 0 } +{ 1S BITS 10 < -> } + +{ 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= -> } + +\ ------------------------------------------------------------------------ +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 -> } + +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 UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +{ GP1 -> } + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +{ GP2 -> } + +: GP3 <# 1 0 # # #> S" 01" S= ; +{ GP3 -> } + +: GP4 <# 1 0 #S #> S" 1" S= ; +{ GP4 -> } + +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 @ + 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 -> } + +: 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 -> } + +: GP7 + BASE @ >R MAX-BASE BASE ! + + 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 -> } + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED } +{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED } +{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED } +{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE +{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING } +{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING } + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED } +{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED } +{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED } +{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED } + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +{ 0 0 2 GN1 -> 0 0 0 } +{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 } +{ 0 0 MAX-BASE GN1 -> 0 0 0 } +{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 } + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +{ GN2 -> 10 A } + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +{ FBUF 0 20 FILL -> } +{ SEEBUF -> 00 00 00 } + +{ FBUF 1 20 FILL -> } +{ SEEBUF -> 20 00 00 } + +{ FBUF 3 20 FILL -> } +{ SEEBUF -> 20 20 20 } + +{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 0 CHARS MOVE -> } +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 1 CHARS MOVE -> } +{ SEEBUF -> 12 20 20 } + +{ SBUF FBUF 3 CHARS MOVE -> } +{ SEEBUF -> 12 34 56 } + +{ FBUF FBUF CHAR+ 2 CHARS MOVE -> } +{ SEEBUF -> 12 12 34 } + +{ FBUF CHAR+ FBUF 2 CHARS MOVE -> } +{ SEEBUF -> 12 34 34 } + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +{ OUTPUT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 80 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 80 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +{ ACCEPT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +{ : GDX 123 ; : GDX GDX 234 ; -> } + +{ GDX -> 123 234 } + + diff --git a/fth/filefind.fth b/fth/filefind.fth index 1d97f84..ea57dec 100644 --- a/fth/filefind.fth +++ b/fth/filefind.fth @@ -1,119 +1,119 @@ -\ @(#) filefind.fth 98/01/26 1.2 -\ FILE? ( -- , 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 -; - +\ @(#) filefind.fth 98/01/26 1.2 +\ FILE? ( -- , report which file this Forth word was defined in ) +\ +\ FILE? looks for ::::Filename and ;;;; in the dictionary +\ that have been left by INCLUDE. It figures out nested +\ includes and reports each file that defines the word. +\ +\ Author: Phil Burk +\ Copyright 1992 Phil Burk +\ +\ 00001 PLB 2/21/92 Handle words from kernel or keyboard. +\ Support EACH.FILE? +\ 961213 PLB Port to pForth. + +ANEW TASK-FILEFIND.FTH + +: BE@ { addr | val -- val , fetch from unaligned address in BigEndian order } + 4 0 + DO + addr i + c@ + val 8 lshift or -> val + LOOP + val +; + +: BE! { val addr -- , store to unaligned address in BigEndian order } + 4 0 + DO + val 3 i - 8 * rshift + addr i + c! + LOOP +; +: BEW@ { addr -- , fetch word from unaligned address in BigEndian order } + addr c@ 8 lshift + addr 1+ c@ OR +; + +: BEW! { val addr -- , store word to unaligned address in BigEndian order } + val 8 rshift addr c! + val addr 1+ c! +; + +\ scan dictionary from NFA for filename +: F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count } + 0 -> dpth + 0 -> stoploop + 0 -> keyb + nfa -> nfa0 + BEGIN + nfa prevname -> nfa + nfa 0> + IF + nfa 1+ be@ + CASE + $ 3a3a3a3a ( :::: ) + OF + dpth 0= + IF + nfa count 31 and + 4 - swap 4 + swap + true -> stoploop + ELSE + -1 dpth + -> dpth + THEN + ENDOF + $ 3b3b3b3b ( ;;;; ) + OF + 1 dpth + -> dpth + true -> keyb \ maybe from keyboard + ENDOF + ENDCASE + ELSE + true -> stoploop + keyb + IF + " keyboard" + ELSE + " 'C' kernel" + THEN + count + THEN + stoploop + UNTIL +; + +: FINDNFA.FROM { $name start_nfa -- nfa true | $word false } + context @ >r + start_nfa context ! + $name findnfa + r> context ! +; + +\ Search entire dictionary for all occurences of named word. +: FILE? { | $word nfa done? -- , take name from input } + 0 -> done? + bl word -> $word + $word findnfa + IF ( -- nfa ) + $word count type ." from:" cr + -> nfa + BEGIN + nfa f?.search.nfa ( addr cnt ) + nfa name> 12 .r \ print xt + 4 spaces type cr + nfa prevname dup -> nfa + 0> + IF + $word nfa findnfa.from \ search from one behind found nfa + swap -> nfa + not + ELSE + true + THEN + UNTIL + ELSE ( -- $word ) + count type ." not found!" cr + THEN +; + diff --git a/fth/floats.fth b/fth/floats.fth index 02d1625..650730f 100644 --- a/fth/floats.fth +++ b/fth/floats.fth @@ -1,502 +1,502 @@ -\ @(#) 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 ( -- , create with float aligned data ) - falign.create - CREATE -; - -: FVARIABLE ( -- ) ( 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.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.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.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.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] +\ @(#) 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 ( -- , create with float aligned data ) + falign.create + CREATE +; + +: FVARIABLE ( -- ) ( 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.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.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.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.append + THEN + fp-output-pad fp-output-ptr @ over - +; + +: F. ( F: r -- ) + (f.) type space +; + +: F.S ( -- , print FP stack ) + ." FP> " + fdepth 0> + IF + fdepth 0 + DO + cr? + fdepth i - 1- \ index of next float + fpick f. cr? + LOOP + ELSE + ." empty" + THEN + cr +; + +\ FP Input ---------------------------------------------------------- +variable FP-REQUIRE-E \ must we put an E in FP numbers? +false fp-require-e ! \ violate ANSI !! + +: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag } + u 0= IF false exit THEN + false -> flag + 0 -> nshift +\ +\ check for minus sign + c-addr c@ [char] - = dup -> fsign + c-addr c@ [char] + = OR + IF 1 +-> c-addr -1 +-> u \ skip char + THEN +\ +\ convert first set of digits + 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo + u' 0> + IF +\ convert optional second set of digits + c-addr c@ [char] . = + IF + dlo dhi c-addr 1+ u' 1- dup -> nshift >number + dup nshift - -> nshift + -> u' -> c-addr -> dhi -> dlo + THEN +\ convert exponent + u' 0> + IF + c-addr c@ [char] E = + c-addr c@ [char] e = OR + IF + 1 +-> c-addr -1 +-> u' \ skip E char + u' 0> + IF + c-addr c@ [char] + = \ ignore + on exponent + IF + 1 +-> c-addr -1 +-> u' \ skip char + THEN + c-addr u' ((number?)) + num_type_single = + IF + nshift + -> nshift + true -> flag + THEN + ELSE + true -> flag \ allow "1E" + THEN + THEN + ELSE +\ only require E field if this variable is true + fp-require-e @ not -> flag + THEN + THEN +\ convert double precision int to float + flag + IF + dlo dhi d>f + 10 s>f nshift s>f f** f* \ apply exponent + fsign + IF + fnegate + THEN + THEN + flag +; + +3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER? + +: (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number ) +\ check to see if it is a valid float, if not use old (NUMBER?) + dup count >float + IF + drop NUM_TYPE_FLOAT + ELSE + (number?) + THEN +; + +defer fp.old.number? +variable FP-IF-INIT + +: FP.TERM ( -- , deinstall fp conversion ) + fp-if-init @ + IF + what's fp.old.number? is number? + fp-if-init off + THEN +; + +: FP.INIT ( -- , install FP converion ) + fp.term + what's number? is fp.old.number? + ['] (fp.number?) is number? + fp-if-init on + ." Floating point numeric conversion installed." cr +; + +FP.INIT +if.forgotten fp.term + + +0 [IF] + +23.8e-9 fconstant fsmall +1.0 fsmall f- fconstant falmost1 +." Should be 1.0 = " falmost1 f. cr + +: TSEGF ( r -f- , print in all formats ) +." --------------------------------" cr + 34 0 + DO + fdup fs. 4 spaces fdup fe. 4 spaces + fdup fg. 4 spaces fdup f. cr + 10.0 f/ + LOOP + fdrop +; + +: TFP + 1.234e+22 tsegf + 1.23456789e+22 tsegf + 0.927 fsin 1.234e+22 f* tsegf +; + +[THEN] diff --git a/fth/forget.fth b/fth/forget.fth index 9dfd800..3971100 100644 --- a/fth/forget.fth +++ b/fth/forget.fth @@ -1,97 +1,97 @@ -\ @(#) 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) ( -- ) - 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 ( -- , 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] ( -- , 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 ( -- , 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 ( -- , 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 -; +\ @(#) 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) ( -- ) + 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 ( -- , 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] ( -- , 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 ( -- , 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 ( -- , define a word that forgets itself when executed, ANS ) + CREATE + latest namebase - \ convert to relocatable + , \ save for DOES> + DOES> ( -- body ) + @ namebase + \ convert back to NFA + verify.forget +; diff --git a/fth/history.fth b/fth/history.fth index 6299d1d..a61caaa 100644 --- a/fth/history.fth +++ b/fth/history.fth @@ -1,513 +1,513 @@ -\ 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 ( ) - 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] +\ 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 ( ) + ELSE 0 false + THEN ( -- char flag ) + WHILE ( -- char ) + kh.inschar + REPEAT drop + kh-span @ kh-cursor @ - ?dup + IF tio.forwards ( move to end of line ) + THEN + space + flushemit +; + +: KH.ACCEPT ( addr max -- numChars ) + swap kh-address ! + kh.getline + kh-span @ 0> + IF kh-buffer kh-span @ kh.add.line + THEN + kh-span @ +; + +: TEST.HISTORY + 4 0 DO + pad 128 kh.accept + cr pad swap type cr + LOOP +; + +}private + + +: HISTORY# ( -- , dump history buffer with numbers) + cr kh.oldest.line ?dup + IF + BEGIN kh.current.num 3 .r ." ) " type ?pause cr + kh.forward.line 0= + WHILE kh.current.line + REPEAT + THEN +; + +: HISTORY ( -- , dump history buffer ) + cr kh.oldest.line ?dup + IF + BEGIN type ?pause cr + kh.forward.line 0= + WHILE kh.current.line + REPEAT + THEN +; + +: XX ( line# -- , execute line x of history ) + kh.find.line ?dup + IF count evaluate + THEN +; + + +: HISTORY.RESET ( -- , clear history tables ) + kh-history kh_history_size erase + kh-counter off +; + +: HISTORY.ON ( -- , install history vectors ) + history.reset + what's accept ['] (accept) = + IF ['] kh.accept is accept + THEN +; + +: HISTORY.OFF ( -- , uninstall history vectors ) + what's accept ['] kh.accept = + IF ['] (accept) is accept + THEN +; + + +: AUTO.INIT + auto.init + history.on +; +: AUTO.TERM + history.off + auto.term +; + +if.forgotten history.off + +0 [IF] +history.reset +history.on +[THEN] diff --git a/fth/loadhist.fth b/fth/loadhist.fth index a7168fc..a57f1ba 100644 --- a/fth/loadhist.fth +++ b/fth/loadhist.fth @@ -1,7 +1,7 @@ -\ 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 +\ Load history and save new dictionary. +\ This is not part of the standard build because some computers +\ do not support ANSI terminal I/O. + +include? ESC[ termio.fth +include? HISTORY history.fth +c" pforth.dic" save-forth diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth index 5cbfe2c..2e9c2ad 100644 --- a/fth/loadp4th.fth +++ b/fth/loadp4th.fth @@ -1,45 +1,45 @@ -\ @(#) 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 +\ @(#) loadp4th.fth 98/01/28 1.3 +\ Load various files needed by PForth +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +include? forget forget.fth +include? >number numberio.fth +include? task-misc1.fth misc1.fth +include? case case.fth +include? $= strings.fth +include? privatize private.fth +include? (local) ansilocs.fth +include? { locals.fth +include? fm/mod math.fth +include? task-misc2.fth misc2.fth +include? [if] condcomp.fth + +\ load floating point support if basic support is in kernel +exists? F* + [IF] include? task-floats.fth floats.fth + [THEN] + +\ useful but optional stuff follows -------------------- + +include? task-member.fth member.fth +include? :struct c_struct.fth +include? smif{ smart_if.fth +include? file? filefind.fth +include? see see.fth +include? words.like wordslik.fth +include? trace trace.fth +include? ESC[ termio.fth +include? HISTORY history.fth + +map diff --git a/fth/locals.fth b/fth/locals.fth index eb02ceb..a145781 100644 --- a/fth/locals.fth +++ b/fth/locals.fth @@ -1,77 +1,77 @@ -\ @(#) $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 - -: { ( -- ) - 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 -; +\ @(#) $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 + +: { ( -- ) + loc-done off + loc-temp-mode off + loc-comment-mode off + BEGIN + bl word count + dup 0> \ make sure we are not at the end of a line + IF + over c@ + CASE + \ handle special characters + ascii } OF loc-done on 2drop ENDOF + ascii | OF loc-temp-mode on 2drop ENDOF + ascii - OF loc-comment-mode on 2drop ENDOF + ascii ) OF ." { ... ) imbalance!" cr abort ENDOF + ascii \ OF postpone \ 2drop ENDOF \ Forth comment + + \ process name + >r ( save char ) + ( addr len ) + loc-comment-mode @ + IF + 2drop + ELSE + \ if in temporary mode, assign local var = 0 + loc-temp-mode @ + IF compile false + THEN + \ otherwise take value from stack + (local) + THEN + r> + ENDCASE + ELSE + 2drop refill 0= abort" End of input while defining local variables!" + THEN + loc-done @ + UNTIL + 0 0 (local) +; immediate + +privatize + +\ tests +: tlv1 { n -- } n dup n * dup n * ; + +: tlv2 { v1 v2 | l1 l2 -- } + v1 . v2 . cr + v1 v2 + -> l1 + l1 . l2 . cr +; diff --git a/fth/math.fth b/fth/math.fth index bad711d..891849c 100644 --- a/fth/math.fth +++ b/fth/math.fth @@ -1,89 +1,89 @@ -\ @(#) 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 -; +\ @(#) math.fth 98/01/26 1.2 +\ Extended Math routines +\ FM/MOD SM/REM +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-math.fth +decimal + +: FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored } + dl dh dabs -> dhp -> dlp + nn abs -> nnp + dlp dhp nnp um/mod -> quo -> rem + dh 0< + IF \ negative dividend + nn 0< + IF \ negative divisor + rem negate -> rem + ELSE \ positive divisor + rem 0= + IF + quo negate -> quo + ELSE + quo 1+ negate -> quo + nnp rem - -> rem + THEN + THEN + ELSE \ positive dividend + nn 0< + IF \ negative divisor + rem 0= + IF + quo negate -> quo + ELSE + nnp rem - negate -> rem + quo 1+ negate -> quo + THEN + THEN + THEN + rem quo +; + +: SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric } + dl dh dabs -> dhp -> dlp + nn abs -> nnp + dlp dhp nnp um/mod -> quo -> rem + dh 0< + IF \ negative dividend + rem negate -> rem + nn 0> + IF \ positive divisor + quo negate -> quo + THEN + ELSE \ positive dividend + nn 0< + IF \ negative divisor + quo negate -> quo + THEN + THEN + rem quo +; + + +: /MOD ( a b -- rem quo ) + >r s>d r> sm/rem +; + +: MOD ( a b -- rem ) + /mod drop +; + +: */MOD ( a b c -- rem a*b/c , use double precision intermediate value ) + >r m* + r> sm/rem +; +: */ ( a b c -- a*b/c , use double precision intermediate value ) + */mod + nip +; diff --git a/fth/member.fth b/fth/member.fth index 160e95f..5aa84bd 100644 --- a/fth/member.fth +++ b/fth/member.fth @@ -1,155 +1,155 @@ -\ @(#) 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 ( -- 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? ( -- offset #bytes ) - ob.findit ob.stats -; - -: SIZEOF() ( OR -- #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 ( -- , declare space for a byte ) - -1 bytes ; - -: SHORT ( -- , declare space for a 16 bit value ) - -2 bytes ; - -: LONG ( -- ) - cell bytes ; - -: UBYTE ( -- , declare space for signed byte ) - 1 bytes ; - -: USHORT ( -- , declare space for signed 16 bit value ) - 2 bytes ; - - -\ Aliases -: APTR ( -- ) long ; -: RPTR ( -- ) -4 bytes ; \ relative relocatable pointer 00001 -: ULONG ( -- ) long ; - -: STRUCT ( -- , define a structure as an ivar ) - [compile] sizeof() bytes -; +\ @(#) 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 ( -- 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? ( -- offset #bytes ) + ob.findit ob.stats +; + +: SIZEOF() ( OR -- #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 ( -- , declare space for a byte ) + -1 bytes ; + +: SHORT ( -- , declare space for a 16 bit value ) + -2 bytes ; + +: LONG ( -- ) + cell bytes ; + +: UBYTE ( -- , declare space for signed byte ) + 1 bytes ; + +: USHORT ( -- , declare space for signed 16 bit value ) + 2 bytes ; + + +\ Aliases +: APTR ( -- ) long ; +: RPTR ( -- ) -4 bytes ; \ relative relocatable pointer 00001 +: ULONG ( -- ) long ; + +: STRUCT ( -- , define a structure as an ivar ) + [compile] sizeof() bytes +; diff --git a/fth/misc1.fth b/fth/misc1.fth index 373e495..da9c154 100644 --- a/fth/misc1.fth +++ b/fth/misc1.fth @@ -1,177 +1,177 @@ -\ @(#) 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 -- , 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 -- , 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 -; - -: $ ( -- 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 -; +\ @(#) 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 -- , 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 -- , 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 +; + +: $ ( -- N , convert next number as hex ) + base @ hex + bl lword number? num_type_single = not + abort" Not a single number!" + swap base ! + state @ + IF [compile] literal + THEN +; immediate + +: .HX ( nibble -- ) + dup 9 > + IF $ 37 + ELSE $ 30 + THEN + emit +; + +variable TAB-WIDTH 8 TAB-WIDTH ! +: TAB ( -- , tab over to next stop ) + out @ tab-width @ mod + tab-width @ swap - spaces +; + +\ Vocabulary listing +: WORDS ( -- ) + 0 latest + BEGIN dup 0<> + WHILE dup id. tab cr? ?pause + prevname + swap 1+ swap + REPEAT drop + cr . ." words" cr +; + +: VLIST words ; + +variable CLOSEST-NFA +variable CLOSEST-XT + +: >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! ) + 0 closest-nfa ! + 0 closest-xt ! + latest + BEGIN dup 0<> + IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) < + IF true ( addr below this cfa, can't be it) + ELSE ( -- addr nfa ) + 2dup name> ( addr nfa addr xt ) = + IF ( found it ! ) dup closest-nfa ! false + ELSE dup name> closest-xt @ > + IF dup closest-nfa ! dup name> closest-xt ! + THEN + true + THEN + THEN + ELSE false + THEN + WHILE + prevname + REPEAT ( -- cfa nfa ) + 2drop + closest-nfa @ +; + +: @EXECUTE ( addr -- , execute if non-zero ) + x@ ?dup + IF execute + THEN +; + +: TOLOWER ( char -- char_lower ) + dup ascii [ < + IF dup ascii @ > + IF ascii A - ascii a + + THEN + THEN +; + +: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) +\ save current input state and switch to passed in string + source >r >r + set-source + -1 push-source-id + >in @ >r + 0 >in ! +\ interpret the string + interpret +\ restore input state + pop-source-id drop + r> >in ! + r> r> set-source +; + +: \S ( -- , comment out rest of file ) + source-id + IF + BEGIN \ using REFILL is safer than popping SOURCE-ID + refill 0= + UNTIL + THEN +; diff --git a/fth/misc2.fth b/fth/misc2.fth index 7d1dafa..cf20173 100644 --- a/fth/misc2.fth +++ b/fth/misc2.fth @@ -1,235 +1,235 @@ -\ @(#) 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 ( -- , 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 ( -- 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< - 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 -; - +\ @(#) 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 ( -- , 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 ( -- 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< + if swap + then +; + +\ sort top two items on stack. +: -2sort ( a b -- a>b | b>a , smallest on top of stack) + 2dup < + if swap + then +; + +: barray ( #bytes -- ) ( index -- addr ) + create allot + does> + +; + +: warray ( #words -- ) ( index -- addr ) + create 2* allot + does> swap 2* + +; + +: array ( #cells -- ) ( index -- addr ) + create cell* allot + does> swap cell* + +; + +: .bin ( n -- , print in binary ) + base @ binary swap . base ! +; +: .dec ( n -- ) + base @ decimal swap . base ! +; +: .hex ( n -- ) + base @ hex swap . base ! +; + +: B->S ( c -- c' , sign extend byte ) + dup $ 80 and + IF + $ FFFFFF00 or + ELSE + $ 000000FF and + THEN +; +: W->S ( 16bit-signed -- 32bit-signed ) + dup $ 8000 and + if + $ FFFF0000 or + ELSE + $ 0000FFFF and + then +; + +: WITHIN { n1 n2 n3 -- flag } + n2 n3 <= + IF + n2 n1 <= + n1 n3 < AND + ELSE + n2 n1 <= + n1 n3 < OR + THEN +; + +: MOVE ( src dst num -- ) + >r 2dup - 0< + IF + r> CMOVE> + ELSE + r> CMOVE + THEN +; + +: ERASE ( caddr num -- ) + dup 0> + IF + 0 fill + ELSE + 2drop + THEN +; + +: BLANK ( addr u -- , set memory to blank ) + DUP 0> + IF + BL FILL + ELSE + 2DROP + THEN +; + +\ Obsolete but included for CORE EXT word set. +: QUERY REFILL DROP ; +VARIABLE SPAN +: EXPECT accept span ! ; +: TIB source drop ; + + +: UNUSED ( -- unused , dictionary space ) + CODELIMIT HERE - +; + +: MAP ( -- , dump interesting dictionary info ) + ." Code Segment" cr + ." CODEBASE = " codebase .hex cr + ." HERE = " here .hex cr + ." CODELIMIT = " codelimit .hex cr + ." Compiled Code Size = " here codebase - . cr + ." CODE-SIZE = " code-size @ . cr + ." Code Room UNUSED = " UNUSED . cr + ." Name Segment" cr + ." NAMEBASE = " namebase .hex cr + ." HEADERS-PTR @ = " headers-ptr @ .hex cr + ." NAMELIMIT = " namelimit .hex cr + ." CONTEXT @ = " context @ .hex cr + ." LATEST = " latest .hex ." = " latest id. cr + ." Compiled Name size = " headers-ptr @ namebase - . cr + ." HEADERS-SIZE = " headers-size @ . cr + ." Name Room Left = " namelimit headers-ptr @ - . cr +; + + +\ Search for substring S2 in S1 +: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag } +\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr +\ if true, s1 contains s2 at addr3 with cnt3 chars remaining +\ if false, s3 = s1 + addr1 -> addr3 + cnt1 -> cnt3 + cnt1 cnt2 < not + IF + cnt1 cnt2 - 1+ 0 + DO + true -> flag + cnt2 0 + ?DO + addr2 i chars + c@ + addr1 i j + chars + c@ <> \ mismatch? + IF + false -> flag + LEAVE + THEN + LOOP + flag + IF + addr1 i chars + -> addr3 + cnt1 i - -> cnt3 + LEAVE + THEN + LOOP + THEN + addr3 cnt3 flag +; + diff --git a/fth/numberio.fth b/fth/numberio.fth index 0641c0b..833ca69 100644 --- a/fth/numberio.fth +++ b/fth/numberio.fth @@ -1,204 +1,204 @@ -\ @(#) 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 -; +\ @(#) numberio.fth 98/01/26 1.2 +\ numberio.fth +\ +\ numeric conversion +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-numberio.fth +decimal + +\ ------------------------ INPUT ------------------------------- +\ Convert a single character to a number in the given base. +: DIGIT ( char base -- n true | char false ) + >r +\ convert lower to upper + dup ascii a < not + IF + ascii a - ascii A + + THEN +\ + dup dup ascii A 1- > + IF ascii A - ascii 9 + 1+ + ELSE ( char char ) + dup ascii 9 > + IF + ( between 9 and A is bad ) + drop 0 ( trigger error below ) + THEN + THEN + ascii 0 - + dup r> < + IF dup 1+ 0> + IF nip true + ELSE drop FALSE + THEN + ELSE drop FALSE + THEN +; + +: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE ) + >r + BEGIN + r@ 0> \ any characters left? + IF + dup c@ base @ + digit ( ud1 c-addr , n true | char false ) + IF + TRUE + ELSE + drop FALSE + THEN + ELSE + false + THEN + WHILE ( -- ud1 c-addr n ) + swap >r ( -- ud1lo ud1hi n ) + swap base @ ( -- ud1lo n ud1hi base ) + um* drop ( -- ud1lo n ud1hi*baselo ) + rot base @ ( -- n ud1hi*baselo ud1lo base ) + um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi ) + d+ ( -- ud2 ) + r> 1+ \ increment char* + r> 1- >r \ decrement count + REPEAT + r> +; + +\ obsolete +: CONVERT ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT ) + 256 >NUMBER DROP +; + +0 constant NUM_TYPE_BAD +1 constant NUM_TYPE_SINGLE +2 constant NUM_TYPE_DOUBLE + +\ This is similar to the F83 NUMBER? except that it returns a number type +\ and then either a single or double precision number. +: ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number ) + dup 0= IF 2drop NUM_TYPE_BAD exit THEN \ any chars? + +\ prepare for >number + 0 0 2swap ( 0 0 c-addr cnt ) + +\ check for '-' at beginning, skip if present + over c@ ascii - = \ is it a '-' + dup >r \ save flag + IF 1- >r 1+ r> ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign ) + THEN +\ + >number dup 0= \ convert as much as we can + IF + 2drop \ drop addr cnt + drop \ drop hi part of num + r@ \ check flag to see if '-' sign used + IF negate + THEN + NUM_TYPE_SINGLE + ELSE ( -- d addr cnt ) + 1 = swap \ if final character is '.' then double + c@ ascii . = AND + IF + r@ \ check flag to see if '-' sign used + IF dnegate + THEN + NUM_TYPE_DOUBLE + ELSE + 2drop + NUM_TYPE_BAD + THEN + THEN + rdrop +; + +: (NUMBER?) ( $addr -- 0 | n 1 | d 2 , convert string to number ) + count ((number?)) +; + +' (number?) is number? +\ hex +\ 0sp c" xyz" (number?) .s +\ 0sp c" 234" (number?) .s +\ 0sp c" -234" (number?) .s +\ 0sp c" 234." (number?) .s +\ 0sp c" -234." (number?) .s +\ 0sp c" 1234567855554444." (number?) .s + + +\ ------------------------ OUTPUT ------------------------------ +\ Number output based on F83 +variable HLD \ points to last character added + +: hold ( char -- , add character to text representation) + -1 hld +! + hld @ c! +; +: <# ( -- , setup conversion ) + pad hld ! +; +: #> ( d -- addr len , finish conversion ) + 2drop hld @ pad over - +; +: sign ( n -- , add '-' if negative ) + 0< if ascii - hold then +; +: # ( d -- d , convert one digit ) + base @ mu/mod rot 9 over < + IF 7 + + THEN + ascii 0 + hold +; +: #s ( d -- d , convert remaining digits ) + BEGIN # 2dup or 0= + UNTIL +; + + +: (UD.) ( ud -- c-addr cnt ) + <# #s #> +; +: UD. ( ud -- , print unsigned double number ) + (ud.) type space +; +: UD.R ( ud n -- ) + >r (ud.) r> over - spaces type +; +: (D.) ( d -- c-addr cnt ) + tuck dabs <# #s rot sign #> +; +: D. ( d -- ) + (d.) type space +; +: D.R ( d n -- , right justified ) + >r (d.) r> over - spaces type +; + +: (U.) ( u -- c-addr cnt ) + 0 (ud.) +; +: U. ( u -- , print unsigned number ) + 0 ud. +; +: U.R ( u n -- , print right justified ) + >r (u.) r> over - spaces type +; +: (.) ( n -- c-addr cnt ) + dup abs 0 <# #s rot sign #> +; +: . ( n -- , print signed number) + (.) type space +; +: .R ( n l -- , print right justified) + >r (.) r> over - spaces type +; diff --git a/fth/private.fth b/fth/private.fth index 782ec1c..d7d465d 100644 --- a/fth/private.fth +++ b/fth/private.fth @@ -1,48 +1,48 @@ -\ @(#) 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 ! -; +\ @(#) private.fth 98/01/26 1.2 +\ PRIVATIZE +\ +\ Privatize words that are only needed within the file +\ and do not need to be exported. +\ +\ Usage: +\ PRIVATE{ +\ : FOO ; \ Everything between PRIVATE{ and }PRIVATE will become private. +\ : MOO ; +\ }PRIVATE +\ : GOO foo moo ; \ can use foo and moo +\ PRIVATIZE \ smudge foo and moo +\ ' foo \ will fail +\ +\ Copyright 1996 Phil Burk +\ +\ 19970701 PLB Use unsigned compares for machines with "negative" addresses. + +anew task-private.fth + +variable private-start +variable private-stop +$ 20 constant FLAG_SMUDGE + +: PRIVATE{ + latest private-start ! + 0 private-stop ! +; +: }PRIVATE + private-stop @ 0= not abort" Extra }PRIVATE" + latest private-stop ! +; +: PRIVATIZE ( -- , smudge all words between PRIVATE{ and }PRIVATE ) + private-start @ 0= abort" Missing PRIVATE{" + private-stop @ 0= abort" Missing }PRIVATE" + private-stop @ + BEGIN + dup private-start @ u> \ 19970701 + WHILE +\ ." Smudge " dup id. cr + dup c@ flag_smudge or over c! + prevname + REPEAT + drop + 0 private-start ! + 0 private-stop ! +; diff --git a/fth/savedicd.fth b/fth/savedicd.fth index 290b01d..99a5e33 100644 --- a/fth/savedicd.fth +++ b/fth/savedicd.fth @@ -1,177 +1,177 @@ -\ @(#) 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 +\ @(#) savedicd.fth 98/01/26 1.2 +\ Save dictionary as data table. +\ +\ Author: Phil Burk +\ Copyright 1987 Phil Burk +\ All Rights Reserved. +\ +\ 970311 PLB Fixed problem with calling SDAD when in HEX mode. +\ 20010606 PLB Fixed AUTO.INIT , started with ';' !! + +decimal +ANEW TASK-SAVE_DIC_AS_DATA + +\ !!! set to 4 for minimally sized dictionary to prevent DIAB +\ compiler from crashing! Allocate more space in pForth. +4 constant SDAD_NAMES_EXTRA \ space for additional names +4 constant SDAD_CODE_EXTRA \ space for additional names + +\ buffer the file I/O for better performance +256 constant SDAD_BUFFER_SIZE +create SDAD-BUFFER SDAD_BUFFER_SIZE allot +variable SDAD-BUFFER-INDEX +variable SDAD-BUFFER-FID + 0 SDAD-BUFFER-FID ! + +: SDAD.FLUSH ( -- ior ) + sdad-buffer sdad-buffer-index @ \ data +\ 2dup type + sdad-buffer-fid @ write-file + 0 sdad-buffer-index ! +; + +: SDAD.EMIT ( char -- ) + sdad-buffer-index @ sdad_buffer_size >= + IF + sdad.flush abort" SDAD.FLUSH failed!" + THEN +\ + sdad-buffer sdad-buffer-index @ + c! + 1 sdad-buffer-index +! +; + +: SDAD.TYPE ( c-addr cnt -- ) + 0 DO + dup c@ sdad.emit \ char to buffer + 1+ \ advance char pointer + LOOP + drop +; + +: $SDAD.LINE ( $addr -- ) + count sdad.type + EOL sdad.emit +; + +: (U8.) ( u -- a l , unsigned conversion, at least 8 digits ) + 0 <# # # # # # # # #S #> +; +: (U2.) ( u -- a l , unsigned conversion, at least 2 digits ) + 0 <# # #S #> +; + +: SDAD.CLOSE ( -- ) + SDAD-BUFFER-FID @ ?dup + IF + sdad.flush abort" SDAD.FLUSH failed!" + close-file drop + 0 SDAD-BUFFER-FID ! + THEN +; + +: SDAD.OPEN ( -- ior, open file ) + sdad.close + s" pfdicdat.h" r/w create-file dup >r + IF + drop ." Could not create file pfdicdat.h" cr + ELSE + SDAD-BUFFER-FID ! + THEN + r> +; + +: SDAD.DUMP.HEX { val -- } + base @ >r hex + s" 0x" sdad.type + val (u8.) sdad.type + r> base ! +; +: SDAD.DUMP.HEX, + s" " sdad.type + sdad.dump.hex + ascii , sdad.emit +; + +: SDAD.DUMP.HEX.BYTE { val -- } + base @ >r hex + s" 0x" sdad.type + val (u2.) sdad.type + r> base ! +; +: SDAD.DUMP.HEX.BYTE, + sdad.dump.hex.byte + ascii , sdad.emit +; + +: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- } + end-address start-address - -> num-bytes + num-bytes 0 + ?DO + i $ 7FF and 0= IF ." 0x" i .hex cr THEN \ progress report + i 15 and 0= + IF + + EOL sdad.emit + s" /* " sdad.type + i sdad.dump.hex + s" : */ " sdad.type + THEN \ 16 bytes per line, print offset + start-address i + c@ + sdad.dump.hex.byte, + LOOP +\ + num-zeros 0 + ?DO + i $ 7FF and 0= IF i . cr THEN \ progress report + i 15 and 0= IF EOL sdad.emit THEN \ 15 numbers per line + 0 sdad.dump.hex.byte, + LOOP +; + +: SDAD.DEFINE { $name val -- } + s" #define " sdad.type + $name count sdad.type + s" (" sdad.type + val sdad.dump.hex + c" )" $sdad.line +; + +: IS.LITTLE.ENDIAN? ( -- flag , is Forth in Little Endian mode? ) + 1 pad ! + pad c@ +; + +: SDAD { | fid -- } + sdad.open abort" sdad.open failed!" +\ Write headers. + c" /* This file generated by the Forth command SDAD */" $sdad.line + + c" HEADERPTR" headers-ptr @ namebase - sdad.define + c" RELCONTEXT" context @ namebase - sdad.define + c" CODEPTR" here codebase - sdad.define + c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define + +." Saving Names" cr + s" static const uint8_t MinDicNames[] = {" sdad.type + namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data + EOL sdad.emit + c" };" $sdad.line + +." Saving Code" cr + s" static const uint8_t MinDicCode[] = {" sdad.type + codebase here SDAD_CODE_EXTRA sdad.dump.data + EOL sdad.emit + c" };" $sdad.line + + sdad.close +; + +if.forgotten sdad.close + +: AUTO.INIT ( -- , init at launch ) + auto.init \ daisy chain initialization + 0 SDAD-BUFFER-FID ! + 0 SDAD-BUFFER-INDEX ! +; + +." Enter: SDAD" cr diff --git a/fth/see.fth b/fth/see.fth index d0765d1..760b034 100644 --- a/fth/see.fth +++ b/fth/see.fth @@ -1,218 +1,218 @@ -\ @(#) see.fth 98/01/26 1.4 -\ SEE ( -- , 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 ( -- , 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] +\ @(#) see.fth 98/01/26 1.4 +\ SEE ( -- , 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 ( -- , disassemble ) + ' + dup ['] FIRST_COLON > + IF + >code (see) + ELSE + >name id. + ." is primitive defined in 'C' kernel." cr + THEN +; + +PRIVATIZE + +0 [IF] + +: SEE.JOKE + dup swap drop +; + +: SEE.IF + IF + ." hello" cr + ELSE + ." bye" cr + THEN + see.joke +; +: SEE.DO + 4 0 + DO + i . cr + LOOP +; +: SEE." + ." Here are some strings." cr + c" Forth string." count type cr + s" Addr/Cnt string" type cr +; + +[THEN] diff --git a/fth/siev.fth b/fth/siev.fth index 7cebf51..e595955 100644 --- a/fth/siev.fth +++ b/fth/siev.fth @@ -1,31 +1,31 @@ -\ #! /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 -; +\ #! /usr/stud/paysan/bin/forth + +DECIMAL +\ : SECS TIME&DATE SWAP 60 * + SWAP 3600 * + NIP NIP NIP ; +CREATE FLAGS 8190 ALLOT +variable eflag +\ FLAGS 8190 + CONSTANT EFLAG + +\ use secondary fill like pForth !!! +: FILL { caddr num charval -- } + num 0 + ?DO + charval caddr i + c! + LOOP +; + +: PRIMES ( -- n ) FLAGS 8190 1 FILL 0 3 EFLAG @ FLAGS + DO I C@ + IF DUP I + DUP EFLAG @ < + IF EFLAG @ SWAP + DO 0 I C! DUP +LOOP + ELSE DROP THEN SWAP 1+ SWAP + THEN 2 + + LOOP DROP ; + +: BENCHMARK 0 100 0 DO PRIMES NIP LOOP ; \ !!! ONLY 100 +\ SECS BENCHMARK . SECS SWAP - CR . .( secs) +: main + flags 8190 + eflag ! + benchmark ( . ) drop +; diff --git a/fth/smart_if.fth b/fth/smart_if.fth index 65077c0..2234e18 100644 --- a/fth/smart_if.fth +++ b/fth/smart_if.fth @@ -1,57 +1,57 @@ -\ @(#) 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 +\ @(#) smart_if.fth 98/01/26 1.2 +\ Smart Conditionals +\ Allow use of if, do, begin, etc.outside of colon definitions. +\ +\ Thanks to Mitch Bradley for the idea. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-smart_if.fth + +variable SMIF-XT \ execution token for conditional code +variable SMIF-DEPTH \ depth of nested conditionals + +: SMIF{ ( -- , if executing, start compiling, setup depth ) + state @ 0= + IF + :noname smif-xt ! + 1 smif-depth ! + ELSE + 1 smif-depth +! + THEN +; + +: }SMIF ( -- , unnest, stop compiling, execute code and forget ) + smif-xt @ + IF + -1 smif-depth +! + smif-depth @ 0 <= + IF + postpone ; \ stop compiling + smif-xt @ execute \ execute conditional code + smif-xt @ >code dp ! \ forget conditional code + 0 smif-xt ! \ clear so we don't mess up later + THEN + THEN +; + +\ redefine conditionals to use smart mode +: IF smif{ postpone if ; immediate +: DO smif{ postpone do ; immediate +: ?DO smif{ postpone ?do ; immediate +: BEGIN smif{ postpone begin ; immediate +: THEN postpone then }smif ; immediate +: REPEAT postpone repeat }smif ; immediate +: UNTIL postpone until }smif ; immediate +: LOOP postpone loop }smif ; immediate +: +LOOP postpone +loop }smif ; immediate diff --git a/fth/strings.fth b/fth/strings.fth index dc998ad..c32c538 100644 --- a/fth/strings.fth +++ b/fth/strings.fth @@ -1,97 +1,97 @@ -\ @(#) 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 ( -- ) - DOES> ( index -- $string ) ($rom) -; - -: TEXTROM ( packed array of strings, unalterable ) - CREATE ( -- ) - DOES> ( index -- address count ) ($rom) count -; - -\ ----------------------------------------------- +\ @(#) 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 ( -- ) + DOES> ( index -- $string ) ($rom) +; + +: TEXTROM ( packed array of strings, unalterable ) + CREATE ( -- ) + DOES> ( index -- address count ) ($rom) count +; + +\ ----------------------------------------------- diff --git a/fth/system.fth b/fth/system.fth index 5cf36f8..b74c812 100644 --- a/fth/system.fth +++ b/fth/system.fth @@ -1,824 +1,824 @@ -: 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. ) - -: \ ( -- , 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 - ; +: 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. ) + +: \ ( -- , 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 ; - -: 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] ( -- , 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 ( -- , 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 ; immediate -: THEN ( f orig -- ) swap ?condition >resolve ; immediate -: BEGIN ( -- f dest ) ?comp 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 - -: ['] ( -- xt , define compile time tick ) - ?comp ' [compile] literal -; immediate - -\ for example: -\ compile time: compile create , (does>) then ; -\ execution time: create , ',' 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 ( -- ) - CREATE 0 , \ IMMEDIATE -\ DOES> [compile] aliteral \ %Q This could be optimised -; - -: 2VARIABLE ( -c- ) ( -x- addr ) - create 0 , 0 , -; - -: CONSTANT ( n -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 -- , 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 ( -- 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 , state smart ) - bl parse drop c@ - state @ - IF [compile] literal - THEN -; immediate - -: CHAR ( -- char , interpret mode ) - bl parse drop c@ -; - -: [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 ", -; - -: .( ( -- , type string delimited by parentheses ) - [CHAR] ) PARSE TYPE -; IMMEDIATE - -: ." ( -- , type string ) - state @ - IF compile (.") ," - ELSE [char] " parse type - THEN -; immediate - - -: .' ( -- , type string delimited by single quote ) - state @ - IF compile (.") [char] ' parse ", - ELSE [char] ' parse type - THEN -; immediate - -: C" ( -- addr , return string address, ANSI ) - state @ - IF compile (c") ," - ELSE [char] " parse pad place pad - THEN -; immediate - -: S" ( -- , -- addr , return string address, ANSI ) - state @ - IF compile (s") ," - ELSE [char] " parse pad place pad count - THEN -; immediate - -: " ( -- , -- addr , return string address ) - [compile] C" -; immediate -: P" ( -- , -- addr , return string address ) - [compile] C" -; immediate - -: "" ( -- 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 ( -- ) - 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 ( -- ) - BL lword - dup include-save-name $move \ save for RI - $include -; - -: RI ( -- , ReInclude previous file as a convenience ) - include-save-name $include -; - -: INCLUDE? ( -- , 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 + +: 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] ( -- , 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 ( -- , 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 ; immediate +: THEN ( f orig -- ) swap ?condition >resolve ; immediate +: BEGIN ( -- f dest ) ?comp 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 + +: ['] ( -- xt , define compile time tick ) + ?comp ' [compile] literal +; immediate + +\ for example: +\ compile time: compile create , (does>) then ; +\ execution time: create , ',' 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 ( -- ) + CREATE 0 , \ IMMEDIATE +\ DOES> [compile] aliteral \ %Q This could be optimised +; + +: 2VARIABLE ( -c- ) ( -x- addr ) + create 0 , 0 , +; + +: CONSTANT ( n -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 -- , 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 ( -- 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 , state smart ) + bl parse drop c@ + state @ + IF [compile] literal + THEN +; immediate + +: CHAR ( -- char , interpret mode ) + bl parse drop c@ +; + +: [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 ", +; + +: .( ( -- , type string delimited by parentheses ) + [CHAR] ) PARSE TYPE +; IMMEDIATE + +: ." ( -- , type string ) + state @ + IF compile (.") ," + ELSE [char] " parse type + THEN +; immediate + + +: .' ( -- , type string delimited by single quote ) + state @ + IF compile (.") [char] ' parse ", + ELSE [char] ' parse type + THEN +; immediate + +: C" ( -- addr , return string address, ANSI ) + state @ + IF compile (c") ," + ELSE [char] " parse pad place pad + THEN +; immediate + +: S" ( -- , -- addr , return string address, ANSI ) + state @ + IF compile (s") ," + ELSE [char] " parse pad place pad count + THEN +; immediate + +: " ( -- , -- addr , return string address ) + [compile] C" +; immediate +: P" ( -- , -- addr , return string address ) + [compile] C" +; immediate + +: "" ( -- 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 ( -- ) + 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 ( -- ) + BL lword + dup include-save-name $move \ save for RI + $include +; + +: RI ( -- , ReInclude previous file as a convenience ) + include-save-name $include +; + +: INCLUDE? ( -- , load file if word not defined ) + bl word find + IF drop bl word drop ( eat word from source ) + ELSE drop include + THEN +; + +\ desired sizes for dictionary loaded after SAVE-FORTH +variable HEADERS-SIZE +variable CODE-SIZE + +: AUTO.INIT + auto.init + codelimit codebase - code-size ! + namelimit namebase - headers-size ! +; +auto.init + +: SAVE-FORTH ( $name -- ) + 0 \ Entry point + headers-ptr @ namebase - 65536 + \ NameSize + headers-size @ MAX + here codebase - 131072 + \ CodeSize + code-size @ MAX + (save-forth) + IF + ." SAVE-FORTH failed!" cr abort + THEN +; + +: TURNKEY ( $name entry-token-- ) + 0 \ NameSize = 0, names not saved in turnkey dictionary + here codebase - 131072 + \ CodeSize, remember that base is HEX + (save-forth) + IF + ." TURNKEY failed!" cr abort + THEN +; + +\ Now that we can load from files, load remainder of dictionary. + +trace-include on +\ Turn this OFF if you do not want to see the contents of the stack after each entry. +trace-stack off + +include loadp4th.fth + +decimal + +: ;;;; ; \ Mark end of this file so FILE? can find things in here. +FREEZE \ prevent forgetting below this point + +.( Dictionary compiled, save in "pforth.dic".) cr +c" pforth.dic" save-forth diff --git a/fth/t_alloc.fth b/fth/t_alloc.fth index 63bf0f1..92814e4 100644 --- a/fth/t_alloc.fth +++ b/fth/t_alloc.fth @@ -1,116 +1,116 @@ -\ @(#) 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 - +\ @(#) t_alloc.fth 97/01/28 1.4 +\ Test PForth ALLOCATE +\ +\ Copyright 1994 3DO, Phil Burk + +anew task-t_alloc.fth +decimal + +64 constant NUM_TAF_SLOTS + +variable TAF-MAX-ALLOC +variable TAF-MAX-SLOT + +\ hold addresses and sizes +NUM_TAF_SLOTS array TAF-ADDRESSES +NUM_TAF_SLOTS array TAF-SIZES + +: TAF.MAX.ALLOC? { | numb addr ior maxb -- max } + 0 -> maxb +\ determine maximum amount we can allocate + 1024 40 * -> numb + BEGIN + numb 0> + WHILE + numb allocate -> ior -> addr + ior 0= + IF \ success + addr free abort" Free failed!" + numb -> maxb + 0 -> numb + ELSE + numb 1024 - -> numb + THEN + REPEAT + maxb +; + +: TAF.INIT ( -- ) + NUM_TAF_SLOTS 0 + DO + 0 i taf-addresses ! + LOOP +\ + taf.max.alloc? ." Total Avail = " dup . cr + dup taf-max-alloc ! + NUM_TAF_SLOTS / taf-max-slot ! +; + +: TAF.ALLOC.SLOT { slotnum | addr size -- } +\ allocate some RAM + taf-max-slot @ 8 - + choose 8 + + dup allocate abort" Allocation failed!" + -> addr + -> size + addr slotnum taf-addresses ! + size slotnum taf-sizes ! +\ +\ paint RAM with slot number + addr size slotnum fill +; + +: TAF.FREE.SLOT { slotnum | addr size -- } + slotnum taf-addresses @ -> addr +\ something allocated so check it and free it. + slotnum taf-sizes @ 0 + DO + addr i + c@ slotnum - + IF + ." Error at " addr i + . + ." , slot# " slotnum . cr + abort + THEN + LOOP + addr free abort" Free failed!" + 0 slotnum taf-addresses ! +; + +: TAF.DO.SLOT { slotnum -- } + slotnum taf-addresses @ 0= + IF + slotnum taf.alloc.slot + ELSE + slotnum taf.free.slot + THEN +; + +: TAF.TERM + NUM_TAF_SLOTS 0 + DO + i taf-addresses @ + IF + i taf.free.slot + THEN + LOOP +\ + taf.max.alloc? dup ." Final MAX = " . cr + ." Original MAX = " taf-max-alloc @ dup . cr + = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr + +; + +: TAF.TEST ( NumTests -- ) + 1 max + dup . ." tests" cr \ flushemit + taf.init + ." Please wait for test to complete..." cr + 0 + DO NUM_TAF_SLOTS choose taf.do.slot + LOOP + taf.term +; + +.( Testing ALLOCATE and FREE) cr +10000 taf.test + diff --git a/fth/t_case.fth b/fth/t_case.fth index e1997fb..664ea63 100644 --- a/fth/t_case.fth +++ b/fth/t_case.fth @@ -1,16 +1,16 @@ -\ 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 -; +\ test CASE +anew test-case +: TCASE ( N -- ) + CASE + 0 OF ." is zero" ENDOF + 1 OF + 2 choose + CASE + 0 OF ." chose zero" ENDOF + 1 OF ." chose one" ENDOF + [ .s cr ." of-depth = " of-depth @ . cr ] + ENDCASE + ENDOF + [ .s cr ." of-depth = " of-depth @ . cr ] + ENDCASE +; diff --git a/fth/t_corex.fth b/fth/t_corex.fth index d747941..33103f4 100644 --- a/fth/t_corex.fth +++ b/fth/t_corex.fth @@ -1,226 +1,226 @@ -\ @(#) 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? ( -- 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 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_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? ( -- 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 char -- addr num ) + PARSE + >R \ save length + PAD R@ CMOVE \ move string to pad + PAD R> +; +T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T + +\ ----------------------------------------------------- PICK +T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T + +\ ----------------------------------------------------- QUERY +T{ ' QUERY 0<> }T{ TRUE }T + +\ ----------------------------------------------------- REFILL +T{ ' REFILL 0<> }T{ TRUE }T + +\ ----------------------------------------------------- RESTORE-INPUT +T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE + +\ ----------------------------------------------------- ROLL +T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T +T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T +T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T +T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T +T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T + +\ ----------------------------------------------------- SOURCE-ID +T{ SOURCE-ID 0<> }T{ TRUE }T +T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T + +\ ----------------------------------------------------- SPAN +T{ ' SPAN 0<> }T{ TRUE }T + +\ ----------------------------------------------------- TO VALUE +333 VALUE MY-VALUE +T{ MY-VALUE }T{ 333 }T +T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T +: TEST.VALUE ( -- 19 100 ) + 100 TO MY-VALUE + 19 + MY-VALUE +; +T{ TEST.VALUE }T{ 19 100 }T + +\ ----------------------------------------------------- TRUE +T{ TRUE }T{ 0 0= }T + +\ ----------------------------------------------------- TUCK +T{ 44 55 66 TUCK }T{ 44 66 55 66 }T + +\ ----------------------------------------------------- U.R +HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR +ABCD4321 C U.R CR DECIMAL + +\ ----------------------------------------------------- U> +T{ -5 3 U> }T{ TRUE }T +T{ 10 8 U> }T{ TRUE }T + +\ ----------------------------------------------------- UNUSED +T{ UNUSED 0> }T{ TRUE }T + +\ ----------------------------------------------------- WITHIN +T{ 4 5 10 WITHIN }T{ 0 }T +T{ 5 5 10 WITHIN }T{ TRUE }T +T{ 9 5 10 WITHIN }T{ TRUE }T +T{ 10 5 10 WITHIN }T{ 0 }T + +T{ 4 10 5 WITHIN }T{ TRUE }T +T{ 5 10 5 WITHIN }T{ 0 }T +T{ 9 10 5 WITHIN }T{ 0 }T +T{ 10 10 5 WITHIN }T{ TRUE }T + +T{ -6 -5 10 WITHIN }T{ 0 }T +T{ -5 -5 10 WITHIN }T{ TRUE }T +T{ 9 -5 10 WITHIN }T{ TRUE }T +T{ 10 -5 10 WITHIN }T{ 0 }T + + +\ ----------------------------------------------------- [COMPILE] +: T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE +: T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; +T{ T.[COMPILE] }T{ TRUE }T + +\ ----------------------------------------------------- \ +}TEST + diff --git a/fth/t_floats.fth b/fth/t_floats.fth index 03d9ba1..05612be 100644 --- a/fth/t_floats.fth +++ b/fth/t_floats.fth @@ -1,134 +1,134 @@ -\ @(#) t_floats.fth 98/02/26 1.1 17:46:04 -\ 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 - +\ @(#) t_floats.fth 98/02/26 1.1 17:46:04 +\ Test ANS Forth FLOAT words. +\ +\ Copyright 1994 3DO, Phil Burk + +INCLUDE? }T{ t_tools.fth + +ANEW TASK-T_FLOATS.FTH + +DECIMAL +3.14159265 fconstant PI + +TEST{ +\ ========================================================== +T{ 1 2 3 }T{ 1 2 3 }T +\ ----------------------------------------------------- D>F F>D +\ test some basic floating point <> integer conversion +T{ 4 0 D>F F>D }T{ 4 0 }T +T{ 835 0 D>F F>D }T{ 835 0 }T +T{ -57 -1 D>F F>D }T{ -57 -1 }T +T{ 15 S>F 2 S>F F/ F>S }T{ 7 }T \ 15.0/2.0 -> 7.5 + +\ ----------------------------------------------------- input +T{ 79.2 F>S }T{ 79 }T +T{ 0.003 F>S }T{ 0 }T + +\ ------------------------------------------------------ F~ +T{ 23.4 23.5 0.2 f~ }T{ true }T +T{ 23.4 23.7 0.2 f~ }T{ false }T +T{ 922.3 922.3 0.0 f~ }T{ true }T +T{ 922.3 922.31 0.0 f~ }T{ false }T +T{ 0.0 0.0 0.0 f~ }T{ true }T +T{ 0.0 -0.0 0.0 f~ }T{ false }T +T{ 50.0 51.0 -0.02 f~ }T{ true }T +T{ 50.0 51.0 -0.002 f~ }T{ false }T +T{ 500.0 510.0 -0.02 f~ }T{ true }T +T{ 500.0 510.0 -0.002 f~ }T{ false }T + +\ convert number to text representation and then back to float +: T_F. ( -- ok? ) ( r ftol -f- ) + fover (f.) >float fswap f~ + AND +; +: T_FS. ( -- ok? ) ( r ftol -f- ) + fover (fs.) >float fswap f~ + AND +; +: T_FE. ( -- ok? ) ( r ftol -f- ) + fover (fe.) >float fswap f~ + AND +; + +: T_FG. ( -- ok? ) ( r ftol -f- ) + fover (f.) >float fswap f~ + AND +; + +: T_F>D ( -- ok? ) ( r ftol -f- ) + fover f>d d>f fswap f~ +; + +T{ 0.0 0.00001 T_F. }T{ true }T +T{ 0.0 0.00001 T_FS. }T{ true }T +T{ 0.0 0.00001 T_FE. }T{ true }T +T{ 0.0 0.00001 T_FG. }T{ true }T +T{ 0.0 0.00001 T_F>D }T{ true }T + +T{ 12.34 -0.0001 T_F. }T{ true }T +T{ 12.34 -0.0001 T_FS. }T{ true }T +T{ 12.34 -0.0001 T_FE. }T{ true }T +T{ 12.34 -0.0001 T_FG. }T{ true }T +T{ 1234.0 -0.0001 T_F>D }T{ true }T + +T{ 2345 S>F 79 S>F F/ -0.0001 T_F. }T{ true }T +T{ 511 S>F -294 S>F F/ -0.0001 T_F. }T{ true }T + +: T.SERIES { N matchCFA | flag -- ok? } ( fstart fmult -f- ) + fswap ( -- fmult fstart ) + true -> flag + N 0 + ?DO + fdup -0.0001 matchCFA execute not + IF + false -> flag + ." T_F_SERIES failed for " i . fdup f. cr + leave + THEN +\ i . fdup f. cr + fover f* + LOOP + matchCFA >name id. ." T.SERIES final = " fs. cr + flag +; + +: T.SERIES_F. ['] t_f. t.series ; +: T.SERIES_FS. ['] t_fs. t.series ; +: T.SERIES_FG. ['] t_fg. t.series ; +: T.SERIES_FE. ['] t_fe. t.series ; +: T.SERIES_F>D ['] t_f>d t.series ; + +T{ 1.0 1.3 150 t.series_f. }T{ true }T +T{ 1.0 -1.3 150 t.series_f. }T{ true }T +T{ 2.3456789 1.3719 150 t.series_f. }T{ true }T + +T{ 3000.0 1.298 120 t.series_f>d }T{ true }T + +T{ 1.2 1.27751 150 t.series_fs. }T{ true }T +T{ 7.43 0.812255 200 t.series_fs. }T{ true }T + +T{ 1.195 1.30071 150 t.series_fe. }T{ true }T +T{ 5.913 0.80644 200 t.series_fe. }T{ true }T + +T{ 1.395 1.55071 120 t.series_fe. }T{ true }T +T{ 5.413 0.83644 160 t.series_fe. }T{ true }T + +\ ----------------------------------------------------- FABS +T{ 0.0 FABS 0.0 0.00001 F~ }T{ true }T +T{ 7.0 FABS 7.0 0.00001 F~ }T{ true }T +T{ -47.3 FABS 47.3 0.00001 F~ }T{ true }T + +\ ----------------------------------------------------- FSQRT +T{ 49.0 FSQRT 7.0 -0.0001 F~ }T{ true }T +T{ 2.0 FSQRT 1.414214 -0.0001 F~ }T{ true }T + +\ ----------------------------------------------------- FSIN +T{ 0.0 FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI 2.0 F* FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI 0.5 F* FSIN 1.0 0.00001 F~ }T{ true }T +T{ PI 6.0 F/ FSIN 0.5 0.00001 F~ }T{ true }T + +\ ----------------------------------------------------- \ +}TEST + diff --git a/fth/t_include.fth b/fth/t_include.fth index db7e646..d7ba7c2 100644 --- a/fth/t_include.fth +++ b/fth/t_include.fth @@ -1,18 +1,18 @@ -\ 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 INCLUDE errors. +\ +\ Copyright 2001Phil Burk + +include? }T{ t_tools.fth + +marker task-t_string.fth + +decimal + +: F_UNDEF " t_load_undef.fth" ; + +test{ + +T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T + + +}test diff --git a/fth/t_load.fth b/fth/t_load.fth index 8efadc3..9475eff 100644 --- a/fth/t_load.fth +++ b/fth/t_load.fth @@ -1,7 +1,7 @@ -\ Test nested INCLUDE errors. -\ -\ Copyright 2001Phil Burk - -\ include t_load_undef.fth -\ include t_load_semi.fth -include t_load_defer.fth +\ Test nested INCLUDE errors. +\ +\ Copyright 2001Phil Burk + +\ include t_load_undef.fth +\ include t_load_semi.fth +include t_load_defer.fth diff --git a/fth/t_load_defer.fth b/fth/t_load_defer.fth index 01b4e8b..c5e79e9 100644 --- a/fth/t_load_defer.fth +++ b/fth/t_load_defer.fth @@ -1,5 +1,5 @@ -\ Test INCLUDE errors. - -what's dup >name id. \ but DUP is not deferred! - -We should never reach this text. +\ Test INCLUDE errors. + +what's dup >name id. \ but DUP is not deferred! + +We should never reach this text. diff --git a/fth/t_load_pairs.fth b/fth/t_load_pairs.fth index b4b93c7..ec41b73 100644 --- a/fth/t_load_pairs.fth +++ b/fth/t_load_pairs.fth @@ -1,5 +1,5 @@ -\ Test INCLUDE errors. - -: T.LOAD.PAIRS - 10 0 DO i . THEN -; +\ Test INCLUDE errors. + +: T.LOAD.PAIRS + 10 0 DO i . THEN +; diff --git a/fth/t_load_semi.fth b/fth/t_load_semi.fth index 83bdd26..4aa3e77 100644 --- a/fth/t_load_semi.fth +++ b/fth/t_load_semi.fth @@ -1,6 +1,6 @@ -\ Test INCLUDE errors. - -: T.LOAD.PAIRS - 1 IF - ." hello" cr -; \ missing a THEN +\ Test INCLUDE errors. + +: T.LOAD.PAIRS + 1 IF + ." hello" cr +; \ missing a THEN diff --git a/fth/t_load_undef.fth b/fth/t_load_undef.fth index 8923a47..2c3c653 100644 --- a/fth/t_load_undef.fth +++ b/fth/t_load_undef.fth @@ -1,5 +1,5 @@ -\ Test INCLUDE errors. - -: T.LOAD.UNDEF - 23 45 swap BADWORD \ reference an undefined word! -; +\ Test INCLUDE errors. + +: T.LOAD.UNDEF + 23 45 swap BADWORD \ reference an undefined word! +; diff --git a/fth/t_locals.fth b/fth/t_locals.fth index aa6e03d..5cec9e0 100644 --- a/fth/t_locals.fth +++ b/fth/t_locals.fth @@ -1,52 +1,52 @@ -\ @(#) 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 - +\ @(#) t_locals.fth 97/01/28 1.1 +\ Test PForth LOCAL variables. +\ +\ Copyright 1996 3DO, Phil Burk + +include? }T{ t_tools.fth + +anew task-t_locals.fth +decimal + +test{ + +\ test value and locals +T{ 333 value my-value my-value }T{ 333 }T +T{ 1000 -> my-value my-value }T{ 1000 }T +T{ 35 +-> my-value my-value }T{ 1035 }T +: test.value ( -- ok ) + 100 -> my-value + my-value 100 = + 47 +-> my-value + my-value 147 = AND +; +T{ test.value }T{ TRUE }T + +\ test locals in a word +: test.locs { aa bb | cc -- ok } + cc 0= + aa bb + -> cc + aa bb + cc = AND + aa -> cc + bb +-> cc + aa bb + cc = AND +; + +T{ 200 59 test.locs }T{ TRUE }T + +.( Test warning when no locals defined.) cr +: loc.nonames { -- } 1234 ; +T{ loc.nonames }T{ 1234 }T + +\ try to put EOLs and comments in variable list +: calc.area { + width \ horizontal dimension + height \ vertical dimension + -- area , calculate area of a rectangle } + width height * +; + +T{ 5 20 calc.area }T{ 100 }T + +}test + diff --git a/fth/t_nolf.fth b/fth/t_nolf.fth index 2ca7c1d..a9e2a9d 100644 --- a/fth/t_nolf.fth +++ b/fth/t_nolf.fth @@ -1,4 +1,4 @@ -\ Test behavior of pForth when line encountered with no EOF at end. - -." First Line of Two" cr -." Second Line of Two" cr \ No newline at end of file +\ Test behavior of pForth when line encountered with no EOF at end. + +." First Line of Two" cr +." Second Line of Two" cr diff --git a/fth/t_strings.fth b/fth/t_strings.fth index 4f48874..bd5e3e6 100644 --- a/fth/t_strings.fth +++ b/fth/t_strings.fth @@ -1,106 +1,106 @@ -\ @(#) 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_strings.fth 97/12/10 1.1 +\ Test ANS Forth String Word Set +\ +\ Copyright 1994 3DO, Phil Burk + +include? }T{ t_tools.fth + +marker task-t_string.fth + +decimal + +test{ + +echo off + +\ ========================================================== +\ test is.ok? +T{ 1 2 3 }T{ 1 2 3 }T + +: STR1 S" Hello " ; +: STR2 S" Hello World" ; +: STR3 S" " ; + +\ ----------------------------------------------------- -TRAILING +T{ STR1 -TRAILING }T{ STR1 DROP 5 }T +T{ STR2 -TRAILING }T{ STR2 }T +T{ STR3 -TRAILING }T{ STR3 }T + +\ ----------------------------------------------------- /STRING +T{ STR2 6 /STRING }T{ STR2 DROP 6 CHARS + STR2 NIP 6 - }T + + +\ ----------------------------------------------------- BLANK +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T{ T-BLANK-DATA 8 + C@ }T{ 8 }T +T-BLANK-DATA 7 + 3 BLANK +T{ T-BLANK-DATA 6 + C@ }T{ 6 }T +T{ T-BLANK-DATA 7 + C@ }T{ BL }T +T{ T-BLANK-DATA 8 + C@ }T{ BL }T +T{ T-BLANK-DATA 9 + C@ }T{ BL }T +T{ T-BLANK-DATA 10 + C@ }T{ 10 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- CMOVE +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T-BLANK-DATA 7 + T-BLANK-DATA 6 + 3 CMOVE +T{ T-BLANK-DATA 5 + C@ }T{ 5 }T +T{ T-BLANK-DATA 6 + C@ }T{ 7 }T +T{ T-BLANK-DATA 7 + C@ }T{ 8 }T +T{ T-BLANK-DATA 8 + C@ }T{ 9 }T +T{ T-BLANK-DATA 9 + C@ }T{ 9 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- CMOVE> +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T{ T-BLANK-DATA 6 + T-BLANK-DATA 7 + 3 CMOVE> +T{ T-BLANK-DATA 5 + C@ }T{ 5 }T +T{ T-BLANK-DATA 6 + C@ }T{ 6 }T +T{ T-BLANK-DATA 7 + C@ }T{ 6 }T +T{ T-BLANK-DATA 8 + C@ }T{ 7 }T +T{ T-BLANK-DATA 9 + C@ }T{ 8 }T +T{ T-BLANK-DATA 10 + C@ }T{ 10 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- COMPARE +T{ : T.COMPARE.1 S" abcd" S" abcd" compare ; t.compare.1 }T{ 0 }T +T{ : T.COMPARE.2 S" abcd" S" abcde" compare ; t.compare.2 }T{ -1 }T +T{ : T.COMPARE.3 S" abcdef" S" abcde" compare ; t.compare.3 }T{ 1 }T +T{ : T.COMPARE.4 S" abGd" S" abcde" compare ; t.compare.4 }T{ -1 }T +T{ : T.COMPARE.5 S" abcd" S" aXcde" compare ; t.compare.5 }T{ 1 }T +T{ : T.COMPARE.6 S" abGd" S" abcd" compare ; t.compare.6 }T{ -1 }T +T{ : T.COMPARE.7 S" World" S" World" compare ; t.compare.7 }T{ 0 }T +FORGET T.COMPARE.1 + +\ ----------------------------------------------------- SEARCH +: STR-SEARCH S" ABCDefghIJKL" ; +T{ : T.SEARCH.1 STR-SEARCH S" ABCD" SEARCH ; T.SEARCH.1 }T{ STR-SEARCH TRUE }T +T{ : T.SEARCH.2 STR-SEARCH S" efg" SEARCH ; T.SEARCH.2 }T{ + STR-SEARCH 4 - SWAP 4 CHARS + SWAP TRUE }T +T{ : T.SEARCH.3 STR-SEARCH S" IJKL" SEARCH ; T.SEARCH.3 }T{ + STR-SEARCH DROP 8 CHARS + 4 TRUE }T +T{ : T.SEARCH.4 STR-SEARCH STR-SEARCH SEARCH ; T.SEARCH.4 }T{ + STR-SEARCH TRUE }T + +T{ : T.SEARCH.5 STR-SEARCH S" CDex" SEARCH ; T.SEARCH.5 }T{ + STR-SEARCH FALSE }T +T{ : T.SEARCH.6 STR-SEARCH S" KLM" SEARCH ; T.SEARCH.6 }T{ + STR-SEARCH FALSE }T +FORGET STR-SEARCH + +\ ----------------------------------------------------- SLITERAL +CREATE FAKE-STRING CHAR H C, CHAR e C, CHAR l C, CHAR l C, CHAR o C, +ALIGN +T{ : T.SLITERAL.1 [ FAKE-STRING 5 ] SLITERAL ; T.SLITERAL.1 FAKE-STRING 5 COMPARE + }T{ 0 }T + +}test diff --git a/fth/t_tools.fth b/fth/t_tools.fth index af6f073..72e2c85 100644 --- a/fth/t_tools.fth +++ b/fth/t_tools.fth @@ -1,83 +1,83 @@ -\ @(#) 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 -; +\ @(#) t_tools.fth 97/12/10 1.1 +\ Test Tools for pForth +\ +\ Based on testing tools from John Hayes +\ (c) 1993 Johns Hopkins University / Applied Physics Laboratory +\ +\ Syntax was changed to avoid conflict with { -> and } for local variables. +\ Also added tracking of #successes and #errors. + +anew task-t_tools.fth + +decimal + +variable TEST-DEPTH +variable TEST-PASSED +variable TEST-FAILED + +: TEST{ + depth test-depth ! + 0 test-passed ! + 0 test-failed ! +; + + +: }TEST + test-passed @ 4 .r ." passed, " + test-failed @ 4 .r ." failed." cr +; + + +VARIABLE actual-depth \ stack record +CREATE actual-results 20 CELLS ALLOT + +: empty-stack \ ( ... -- ) Empty stack. + DEPTH dup 0> + IF 0 DO DROP LOOP + ELSE drop + THEN ; + +CREATE the-test 128 CHARS ALLOT + +: ERROR \ ( c-addr u -- ) Display an error message followed by + \ the line that had the error. + TYPE the-test COUNT TYPE CR \ display line corresponding to error + empty-stack \ throw away every thing else +; + + +: T{ + source the-test place + empty-stack +; + +: }T{ \ ( ... -- ) Record depth and content of stack. + DEPTH actual-depth ! \ record depth + DEPTH 0 + ?DO + actual-results I CELLS + ! + LOOP \ save them +; + +: }T \ ( ... -- ) Compare stack (expected) contents with saved + \ (actual) contents. + DEPTH + actual-depth @ = + IF \ if depths match + 1 test-passed +! \ assume will pass + DEPTH 0 + ?DO \ for each stack item + actual-results I CELLS + @ \ compare actual with expected + <> + IF + -1 test-passed +! + 1 test-failed +! + S" INCORRECT RESULT: " error + LEAVE + THEN + LOOP + ELSE \ depth mismatch + 1 test-failed +! + S" WRONG NUMBER OF RESULTS: " error + THEN +; diff --git a/fth/termio.fth b/fth/termio.fth index ef6d19b..ab8cc17 100644 --- a/fth/termio.fth +++ b/fth/termio.fth @@ -1,88 +1,88 @@ -\ 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] +\ Terminal I/O +\ +\ Requires an ANSI compatible terminal. +\ +\ To get Windows computers to use ANSI mode in their DOS windows, +\ Add this line to "C:\CONFIG.SYS" then reboot. +\ +\ device=c:\windows\command\ansi.sys +\ +\ Author: Phil Burk +\ Copyright 1988 Phil Burk +\ Revised 2001 for pForth + +ANEW TASK-TERMIO.FTH +decimal + +$ 08 constant ASCII_BACKSPACE +$ 7F constant ASCII_DELETE +$ 1B constant ASCII_ESCAPE +$ 01 constant ASCII_CTRL_A +$ 05 constant ASCII_CTRL_E +$ 18 constant ASCII_CTRL_X + +\ ANSI Terminal Control +: ESC[ ( send ESCAPE and [ ) + ASCII_ESCAPE emit + ascii [ emit +; + +: CLS ( -- , clear screen ) + ESC[ ." 2J" +; + +: TIO.BACKWARDS ( n -- , move cursor backwards ) + ESC[ + base @ >r decimal + 0 .r + r> base ! + ascii D emit +; + +: TIO.FORWARDS ( n -- , move cursor forwards ) + ESC[ + base @ >r decimal + 0 .r + r> base ! + ascii C emit +; + +: TIO.ERASE.EOL ( -- , erase to the end of the line ) + ESC[ + ascii K emit +; + + +: BELL ( -- , ring the terminal bell ) + 7 emit +; + +: BACKSPACE ( -- , backspace action ) + 8 emit space 8 emit +; + +0 [IF] \ for testing + +: SHOWKEYS ( -- , show keys pressed in hex ) + BEGIN + key + dup . + ." , $ " dup .hex cr + ascii q = + UNTIL +; + +: AZ ascii z 1+ ascii a DO i emit LOOP ; + +: TEST.BACK1 + AZ 5 tio.backwards + 1000 msec + tio.erase.eol +; +: TEST.BACK2 + AZ 10 tio.backwards + 1000 msec + ." 12345" + 1000 msec +; +[THEN] diff --git a/fth/tester.fth b/fth/tester.fth index 91b1294..9ad2fc9 100644 --- a/fth/tester.fth +++ b/fth/tester.fth @@ -1,54 +1,54 @@ -\ 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 ; - +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.1 +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: { \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP + THEN ; + diff --git a/fth/trace.fth b/fth/trace.fth index 26078d0..c311bc4 100644 --- a/fth/trace.fth +++ b/fth/trace.fth @@ -1,460 +1,460 @@ -\ @(#) trace.fth 98/01/28 1.2 -\ TRACE ( -- , trace pForth word ) -\ -\ Single step debugger. -\ TRACE ( i*x -- , 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 -- 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 -- , 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] +\ @(#) trace.fth 98/01/28 1.2 +\ TRACE ( -- , trace pForth word ) +\ +\ Single step debugger. +\ TRACE ( i*x -- , 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 -- 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 -- , setup trace for Forth word )" cr + ." S ( -- , step over )" cr + ." SM ( many -- , step over many times )" cr + ." SD ( -- , step down )" cr + ." G ( -- , go to end of word )" cr + ." GD ( n -- , go down N levels from current level," cr + ." stop at end of this level )" cr +; + +privatize + +0 [IF] +variable var1 +100 var1 ! +: FOO dup IF 1 + . THEN 77 var1 @ + . ; +: ZOO 29 foo 99 22 + . ; +: ROO 92 >r 1 r@ + . r> . ; +: MOO c" hello" count type + ." This is a message." cr + s" another message" type cr +; +: KOO 7 FOO ." DONE" ; +: TR.DO 4 0 DO i . LOOP ; +: TR.?DO 0 ?DO i . LOOP ; +: TR.LOC1 { aa bb } aa bb + . ; +: TR.LOC2 789 >r 4 5 tr.loc1 r> . ; + +[THEN] diff --git a/fth/tut.fth b/fth/tut.fth index ea60f18..c52eafa 100644 --- a/fth/tut.fth +++ b/fth/tut.fth @@ -1,70 +1,70 @@ -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 - +anew task-tut.fth + +: SUM.OF.N.A ( N -- SUM[N] , calculate sum of N integers ) + 0 \ starting value of SUM + BEGIN + OVER 0> \ Is N greater than zero? + WHILE + OVER + \ add N to sum + SWAP 1- SWAP \ decrement N + REPEAT + SWAP DROP \ get rid on N + ; + +: SUM.OF.N.B ( N -- SUM[N] ) + 0 SWAP \ starting value of SUM + 1+ 0 \ set indices for DO LOOP + ?DO \ safer than DO if N=0 + I + + LOOP +; + +: SUM.OF.N.C ( N -- SUM[N] ) + 0 \ starting value of SUM + BEGIN ( -- N' SUM ) + OVER + + SWAP 1- SWAP + OVER 0< + UNTIL + SWAP DROP +; + +: SUM.OF.N.D ( N -- SUM[N] ) + >R \ put NUM on return stack + 0 \ starting value of SUM + BEGIN ( -- SUM ) + R@ + \ add num to sum + R> 1- DUP >R + 0< + UNTIL + RDROP \ get rid of NUM +; + +: SUM.OF.N.E { NUM | SUM -- SUM[N] , use return stack } + BEGIN + NUM +-> SUM \ add NUM to SUM + -1 +-> NUM \ decrement NUM + NUM 0< + UNTIL + SUM \ return SUM +; + +: SUM.OF.N.F ( NUM -- SUM[N] , Gauss' method ) + DUP 1+ * 2/ +; + + +: TTT + 10 0 + DO + I SUM.OF.N.A . + I SUM.OF.N.B . + I SUM.OF.N.C . + I SUM.OF.N.D . + I SUM.OF.N.E . + I SUM.OF.N.F . + CR + LOOP +; +TTT + diff --git a/fth/utils/clone.fth b/fth/utils/clone.fth index 99c0297..98254b5 100644 --- a/fth/utils/clone.fth +++ b/fth/utils/clone.fth @@ -1,489 +1,489 @@ -\ @(#) 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 ( -- ) - bl word - ." Save cloned image in " dup count type - drop ." SAVE-CLONE unimplemented!" \ %Q -; - -: CLONE ( -- ) - ' '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 - +\ @(#) 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 ( -- ) + bl word + ." Save cloned image in " dup count type + drop ." SAVE-CLONE unimplemented!" \ %Q +; + +: CLONE ( -- ) + ' 'clone +; + +if.forgotten cl.term + +\ ---------------------------------- TESTS -------------------- + + +: TEST.CLONE ( -- ) + cl-test-mode @ not abort" CL-TEST-MODE not on!" + 0 cl.ref[] s@ clr_NewXT execute +; + + +: TEST.CLONE.REAL ( -- ) + cl-test-mode @ abort" CL-TEST-MODE on!" + code-base @ + 0 cl.ref[] s@ clr_NewXT \ get cloned execution token + cl-dict-base @ code-base ! +\ WARNING - code-base munged, only execute primitives or cloned code + execute + code-base ! \ restore code base for normal +; + + +: TCL1 + 34 dup + +; + +: TCL2 + ." Hello " tcl1 . cr +; + +: TCL3 + 4 0 + DO + tcl2 + i . cr + i 100 + . cr + LOOP +; + +create VAR1 567 , +: TCL4 + 345 var1 ! + ." VAR1 = " var1 @ . cr + var1 @ 345 - + IF + ." TCL4 failed!" cr + ELSE + ." TCL4 succeded! Yay!" cr + THEN +; + +\ do deferred words get cloned! +defer tcl.vector + +: TCL.DOIT ." Hello Fred!" cr ; +' tcl.doit is tcl.vector + +: TCL.DEFER + 12 . cr + tcl.vector + 999 dup + . cr +; + +trace-stack on +cl-test-mode on + diff --git a/fth/utils/dump_struct.fth b/fth/utils/dump_struct.fth index 39a32c0..5010e57 100644 --- a/fth/utils/dump_struct.fth +++ b/fth/utils/dump_struct.fth @@ -1,122 +1,122 @@ -\ @(#) 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 -- , 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] - +\ @(#) 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 -- , dump contents of structure ) + ob.findit + state @ + IF [compile] literal compile dump.struct + ELSE dump.struct + THEN +; immediate + +: ADST ( absolute_address -- , dump structure ) + use->rel [compile] dst \ mod 090609 +; immediate + +\ For Testing Purposes +false [IF] +:STRUCT GOO + LONG DATAPTR + SHORT GOO_WIDTH + USHORT GOO_HEIGHT +;STRUCT + +:STRUCT FOO + LONG ALONG1 + STRUCT GOO AGOO + SHORT ASHORT1 + BYTE ABYTE + BYTE ABYTE2 +;STRUCT + +FOO AFOO +: AFOO.INIT + $ 12345678 afoo s! along1 + $ -665 afoo s! ashort1 + $ 21 afoo s! abyte + $ 43 afoo s! abyte2 + -234 afoo .. agoo s! goo_height +; +afoo.init + +: TDS ( afoo -- ) + dst foo +; + +[THEN] + diff --git a/fth/utils/load_file.fth b/fth/utils/load_file.fth index 669ffc3..d015c6a 100644 --- a/fth/utils/load_file.fth +++ b/fth/utils/load_file.fth @@ -1,39 +1,39 @@ -\ 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 . +\ Load a file into an allocated memory image. +\ +\ Author: Phil Burk +\ Copyright 3DO 1995 + +anew task-load_file.fth + +: $LOAD.FILE { $filename | fid numbytes numread err data -- data-addr 0 | 0 err } + 0 -> data +\ open file + $filename count r/o open-file -> err -> fid + err + IF + ." $LOAD.FILE - Could not open input file!" cr + ELSE +\ determine size of file + fid file-size -> err -> numbytes + err + IF + ." $LOAD.FILE - File size failed!" cr + ELSE + ." File size = " numbytes . cr +\ allocate memory for sample, when done free memory using FREE + numbytes allocate -> err -> data + err + IF + ." $LOAD.FILE - Memory allocation failed!" cr + ELSE +\ read data + data numbytes fid read-file -> err + ." Read " . ." bytes from file " $filename count type cr + THEN + THEN + fid close-file drop + THEN + data err +; + +\ Example: c" myfile" $load.file abort" Oops!" free . diff --git a/fth/utils/make_all256.fth b/fth/utils/make_all256.fth index 72d2eed..4a12f64 100644 --- a/fth/utils/make_all256.fth +++ b/fth/utils/make_all256.fth @@ -1,57 +1,57 @@ -\ @(#) 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 +\ @(#) make_all256.fth 97/12/10 1.1 +\ Make a file with all possible 256 bytes in random order. +\ +\ Author: Phil Burk +\ Copyright 1987 Phil Burk +\ All Rights Reserved. + +ANEW TASK-MAKE_ALL256 + +variable RAND8-SEED +19 rand8-seed ! +: RANDOM8 ( -- r8 , generate random bytes, repeat every 256 ) + RAND8-SEED @ + 77 * 55 + + $ FF and + dup RAND8-SEED ! +; + +create rand8-pad 256 allot +: make.256.data + 256 0 + DO + random8 rand8-pad i + c! + LOOP +; + +: SHUFFLE.DATA { num | ind1 ind2 -- } + num 0 + DO + 256 choose -> ind1 + 256 choose -> ind2 + ind1 rand8-pad + c@ + ind2 rand8-pad + c@ + ind1 rand8-pad + c! + ind2 rand8-pad + c! + LOOP +; + +: WRITE.256.FILE { | fid -- } + p" all256.raw" count r/w create-file + IF + drop ." Could not create file." cr + ELSE + -> fid + fid . cr + rand8-pad 256 fid write-file abort" write failed!" + fid close-file drop + THEN +; + +: MAKE.256.FILE + make.256.data + 1000 shuffle.data + write.256.file +; + +MAKE.256.FILE diff --git a/fth/wordslik.fth b/fth/wordslik.fth index ff73c63..e5ebd5a 100644 --- a/fth/wordslik.fth +++ b/fth/wordslik.fth @@ -1,44 +1,44 @@ -\ @(#) wordslik.fth 98/01/26 1.2 -\ -\ WORDS.LIKE ( -- , 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 ( -- , 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 -; +\ @(#) wordslik.fth 98/01/26 1.2 +\ +\ WORDS.LIKE ( -- , 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 ( -- , print all words containing substring ) + BL word latest + >newline + BEGIN + prevname dup 0<> \ get previous name in dictionary + WHILE + 2dup partial.match.name + IF + dup id. tab + cr? + THEN + REPEAT 2drop + >newline +; diff --git a/readme.txt b/readme.txt index 22fc1ce..de7cf90 100644 --- a/readme.txt +++ b/readme.txt @@ -1,92 +1,92 @@ -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. +README for pForth - a Portable ANS-like Forth written in ANSI 'C' + +by Phil Burk +with Larry Polansky, David Rosenboom and Darren Gibbs. +Support for 64-bit cells by Aleksej Saushev. + +Last updated: December 23, 2014 V27 + +Code for pForth is maintained on GitHub at: + https://github.com/philburk/pforth + +Documentation for pForth at: + http://www.softsynth.com/pforth/ + +For technical support please use the pForth forum at: + http://groups.google.com/group/pforthdev + +-- LEGAL NOTICE ----------------------------------------- + +The pForth software code is dedicated to the public domain, +and any third party may reproduce, distribute and modify +the pForth software code or any derivative works thereof +without any compensation or license. The pForth software +code is provided on an "as is" basis without any warranty +of any kind, including, without limitation, the implied +warranties of merchantability and fitness for a particular +purpose and their equivalents under the laws of any jurisdiction. + +-- Contents of SDK -------------------------------------- + + build - tools for building pForth on various platforms + build/win32/vs2005 - Visual Studio 2005 Project and Solution + build/unix - Makefile for unix + + csrc - pForth kernel in ANSI 'C' + csrc/pf_main.c - main() application for a standalone Forth + csrc/stdio - I/O code using basic stdio for generic platforms + csrc/posix - I/O code for Posix platform + csrc/win32 - I/O code for basic WIN32 platform + csrc/win32_console - I/O code for WIN32 console that supports command line history + + fth - Forth code + fth/util - utility functions + +-- How to build pForth ------------------------------------ + +See pForth reference manual at: + + http://www.softsynth.com/pforth/pf_ref.php + +-- How to run pForth ------------------------------------ + +Once you have compiled and built the dictionary, just enter: + pforth + +To compile source code files use: INCLUDE filename + +To create a custom dictionary enter in pForth: + c" newfilename.dic" SAVE-FORTH +The name must end in ".dic". + +To run PForth with the new dictionary enter in the shell: + pforth -dnewfilename.dic + +To run PForth and automatically include a forth file: + pforth myprogram.fth + +-- How to Test PForth ------------------------------------ + +You can test the Forth without loading a dictionary +which might be necessary if the dictionary can't be built. + +Enter: pforth -i +In pForth, enter: 3 4 + . +In pForth, enter: loadsys +In pForth, enter: 10 0 do i . loop + +PForth comes with a small test suite. To test the Core words, +you can use the coretest developed by John Hayes. + +Enter: pforth +Enter: include tester.fth +Enter: include coretest.fth + +To run the other tests, enter: + + pforth t_corex.fth + pforth t_strings.fth + pforth t_locals.fth + pforth t_alloc.fth + +They will report the number of tests that pass or fail. diff --git a/releases.txt b/releases.txt index 5c2e189..c611579 100644 --- a/releases.txt +++ b/releases.txt @@ -1,276 +1,276 @@ -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 +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