pforth-21/ 40775 1750 1750 0 6641456045 11140 5ustar bdalebdalepforth-21/csrc/ 40775 1750 1750 0 6641456017 12071 5ustar bdalebdalepforth-21/csrc/pf_cglue.c100664 1750 1750 5570 6512260632 14116 0ustar bdalebdale/* @(#) 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, 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 "pf_all.h" typedef cell (*CFunc0)( void ); typedef cell (*CFunc1)( cell P1 ); typedef cell (*CFunc2)( cell P1, cell P2 ); typedef cell (*CFunc3)( cell P1, cell P2, cell P3 ); typedef cell (*CFunc4)( cell P1, cell P2, cell P3, cell P4 ); typedef cell (*CFunc5)( cell P1, cell P2, cell P3, cell P4, cell P5 ); extern void *CustomFunctionTable[]; /***************************************************************/ int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ) { cell P1, P2, P3, P4, P5; cell Result = 0; void *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, uint32 Index, int32 ReturnMode, int32 NumParams ) { uint32 Packed; char FName[40]; CStringToForth( FName, CName ); 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 pforth-21/csrc/pf_cglue.h100664 1750 1750 2332 6510350772 14117 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif Err CreateGlueToC( const char *CName, uint32 Index, int32 ReturnMode, int32 NumParams ); Err CompileCustomFunctions( void ); Err LoadCustomFunctionTable( void ); int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ); #ifdef __cplusplus } #endif #define C_RETURNS_VOID (0) #define C_RETURNS_VALUE (1) #endif /* _pf_c_glue_h */ pforth-21/csrc/pf_clib.c100664 1750 1750 3635 6577765104 13747 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** 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 pfCStringLength( const char *s ) { cell len = 0; while( *s++ != NUL ) len++; return len; } /* void *memset (void *s, int32 c, size_t n); */ void *pfSetMemory( void *s, cell c, cell n ) { uint8 *p = s, byt = (uint8) c; while( (n--) > 0) *p++ = byt; return s; } /* void *memccpy (void *s1, const void *s2, int32 c, size_t n); */ void *pfCopyMemory( void *s1, const void *s2, cell n) { uint8 *p1 = s1; const uint8 *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 ); } pforth-21/csrc/pf_clib.h100664 1750 1750 3235 6564620424 13737 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef PF_NO_CLIB #ifdef __cplusplus extern "C" { #endif cell pfCStringLength( const char *s ); void *pfSetMemory( void *s, cell c, cell n ); void *pfCopyMemory( void *s1, const void *s2, cell 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 */ pforth-21/csrc/pf_core.c100664 1750 1750 27303 6567132652 13777 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** 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 ***************************************************************/ cfTaskData *gCurrentTask; cfDictionary *gCurrentDictionary; int32 gNumPrimitives; char gScratch[TIB_SIZE]; ExecToken gLocalCompiler_XT; /* custom compiler for local variables */ /* Depth of data stack when colon called. */ int32 gDepthAtColon; /* Global Forth variables. */ char *gVarContext; /* Points to last name field. */ cell gVarState; /* 1 if compiling. */ cell gVarBase; /* Numeric Base. */ cell gVarEcho; /* Echo input. */ cell gVarTraceLevel; /* Trace Level for Inner Interpreter. */ cell gVarTraceStack; /* Dump Stack each time if true. */ cell gVarTraceFlags; /* Enable various internal debug messages. */ cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ #define DEFAULT_RETURN_DEPTH (512) #define DEFAULT_USER_DEPTH (512) #define DEFAULT_HEADER_SIZE (120000) #define DEFAULT_CODE_SIZE (300000) /* Initialize non-zero globals in a function to simplify loading on * embedded systems which may only support uninitialized data segments. */ void pfInitGlobals( void ) { gVarBase = 10; gVarTraceStack = 1; gDepthAtColon = DEPTH_AT_COLON_INVALID; } /*************************************************************** ** Task Management ***************************************************************/ void pfDeleteTask( cfTaskData *cftd ) { 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) cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ) { cfTaskData *cftd; cftd = ( cfTaskData * ) pfAllocMem( sizeof( cfTaskData ) ); if( !cftd ) goto nomem; pfSetMemory( cftd, 0, sizeof( cfTaskData )); /* Allocate User Stack */ cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * (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 *) pfAllocMem((uint32)(sizeof(int32) * 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((uint32)(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 cftd; nomem: ERR("CreateTaskContext: insufficient memory.\n"); if( cftd ) pfDeleteTask( cftd ); return NULL; } /*************************************************************** ** Dictionary Management ***************************************************************/ void pfExecByName( const char *CString ) { if( NAME_BASE != NULL) { ExecToken autoInitXT; if( ffFindC( CString, &autoInitXT ) ) { pfExecuteToken( autoInitXT ); } } } /*************************************************************** ** Delete a dictionary created by pfCreateDictionary() */ void pfDeleteDictionary( cfDictionary *dic ) { 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. */ cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ) { /* Allocate memory for initial dictionary. */ cfDictionary *dic; dic = ( cfDictionary * ) pfAllocMem( sizeof( cfDictionary ) ); if( !dic ) goto nomem; pfSetMemory( dic, 0, sizeof( cfDictionary )); dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS; /* Align dictionary segments to preserve alignment of floats across hosts. */ #define DIC_ALIGNMENT_SIZE (0x10) #define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))) /* Allocate memory for header. */ if( HeaderSize > 0 ) { dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE ); if( !dic->dic_HeaderBaseUnaligned ) goto nomem; /* Align header base. */ dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned); pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize); dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize; dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase; } else { dic->dic_HeaderBase = NULL; } /* Allocate memory for code. */ dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE ); if( !dic->dic_CodeBaseUnaligned ) goto nomem; dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned); pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize); dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize; dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES); return dic; nomem: pfDeleteDictionary( dic ); return NULL; } /*************************************************************** ** Used by Quit and other routines to restore system. ***************************************************************/ void ResetForthTask( 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( cfTaskData *cftd ) { gCurrentTask = cftd; } /*************************************************************** ** Set Quiet Flag. ***************************************************************/ void pfSetQuiet( int32 IfQuiet ) { gVarQuiet = (cell) IfQuiet; } /*************************************************************** ** Query message status. ***************************************************************/ int32 pfQueryQuiet( void ) { return gVarQuiet; } /*************************************************************** ** RunForth ***************************************************************/ int32 pfRunForth( void ) { ffQuit(); return gVarReturnCode; } /*************************************************************** ** Include file based on 'C' name. ***************************************************************/ int32 pfIncludeFile( const char *FileName ) { FileStream *fid; int32 Result; char buffer[32]; int32 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 = 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 ); /* Create a dictionary word named ;;;; for FILE? */ CreateDicEntryC( ID_NOOP, ";;;;", 0 ); sdCloseFile(fid); return Result; } /*************************************************************** ** 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. ***************************************************************/ void pfMessage( const char *CString ) { ioType( CString, pfCStringLength(CString) ); } /************************************************************************** ** Main entry point fo pForth */ int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ) { cfTaskData *cftd; cfDictionary *dic; int32 Result = 0; ExecToken EntryPoint = 0; #ifdef PF_USER_INIT Result = PF_USER_INIT; if( Result < 0 ) goto error; #endif pfInitGlobals(); /* Allocate Task structure. */ cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH ); if( cftd ) { pfSetCurrentTask( cftd ); if( !pfQueryQuiet() ) { MSG( "PForth V"PFORTH_VERSION"\n" ); } #if 0 /* Don't use MSG before task set. */ if( IfInit ) MSG("Build dictionary from scratch.\n"); if( DicName ) { MSG("DicName = "); MSG(DicName); MSG("\n"); } if( SourceName ) { MSG("SourceName = "); MSG(SourceName); MSG("\n"); } #endif #ifdef PF_NO_GLOBAL_INIT if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */ #endif #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) if( IfInit ) { dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE ); } else #else TOUCH(IfInit); #endif /* !PF_NO_INIT && !PF_NO_SHELL*/ { dic = pfLoadDictionary( DicName, &EntryPoint ); } if( dic == NULL ) goto error; pfExecByName("AUTO.INIT"); if( EntryPoint != 0 ) { pfExecuteToken( EntryPoint ); } #ifndef PF_NO_SHELL else { if( SourceName == NULL ) { Result = pfRunForth(); } else { MSG("Including: "); MSG(SourceName); MSG("\n"); Result = pfIncludeFile( SourceName ); } } #endif /* PF_NO_SHELL */ pfExecByName("AUTO.TERM"); pfDeleteDictionary( dic ); pfDeleteTask( cftd ); } #ifdef PF_USER_TERM PF_USER_TERM; #endif return Result; error: MSG("pfDoForth: Error occured.\n"); pfDeleteTask( cftd ); return -1; } pforth-21/csrc/pf_core.h100664 1750 1750 3122 6510350772 13746 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif /* Main entry point fo pForth. */ int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); void pfInitGlobals( void ); cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); void pfDeleteTask( cfTaskData *cftd ); void pfSetCurrentTask( cfTaskData *cftd ); cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ); void pfDeleteDictionary( cfDictionary *dic ); void pfSetQuiet( int32 IfQuiet ); int32 pfQueryQuiet( void ); int32 pfRunForth( void ); int32 pfIncludeFile( const char *FileName ); void pfMessage( const char *CString ); void pfExecByName( const char *CString ); void ResetForthTask( void ); #ifdef __cplusplus } #endif #endif /* _pf_core_h */ pforth-21/csrc/pf_guts.h100664 1750 1750 34434 6600014436 14024 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ /* ** PFORTH_VERSION changes when PForth is modified and released. ** See README file for version info. */ #define PFORTH_VERSION "21" /* ** 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. */ #define PF_FILE_VERSION (8) /* Bump this whenever primitives added. */ #define PF_EARLIEST_FILE_VERSION (8) /* 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)) /*************************************************************** ** 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, 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, /* 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_RESERVED14, ID_RESERVED15, ID_RESERVED16, ID_RESERVED17, ID_RESERVED18, ID_RESERVED19, ID_RESERVED20, 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 */ }; /*************************************************************** ** Structures ***************************************************************/ #define CFTD_FLAG_GO (0x0001) /* This flag is true when ABORTing to cause the 'C' code to unravel. */ #define CFTD_FLAG_ABORT (0x0002) typedef struct cfTaskData { cell *td_StackPtr; /* Primary data stack */ cell *td_StackBase; cell *td_StackLimit; cell *td_ReturnPtr; /* Return stack */ cell *td_ReturnBase; cell *td_ReturnLimit; #ifdef PF_SUPPORT_FP PF_FLOAT *td_FloatStackPtr; PF_FLOAT *td_FloatStackBase; PF_FLOAT *td_FloatStackLimit; #endif cell *td_InsPtr; /* Instruction pointer, "PC" */ cell td_Flags; FileStream *td_InputStream; /* Terminal. */ char td_TIB[TIB_SIZE]; /* Buffer for terminal input. */ cell td_IN; /* Index into Source */ cell td_SourceNum; /* #TIB after REFILL */ char *td_SourcePtr; /* Pointer to TIB or other source. */ int32 td_LineNumber; /* Incremented on every refill. */ cell td_OUT; /* Current output column. */ } cfTaskData; 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 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 cfDictionary { pfNode dic_Node; uint32 dic_Flags; /* Headers contain pointers to names and dictionary. */ uint8 *dic_HeaderBaseUnaligned; uint8 *dic_HeaderBase; union { cell *Cell; uint8 *Byte; } dic_HeaderPtr; uint8 *dic_HeaderLimit; /* Code segment contains tokenized code and data. */ uint8 *dic_CodeBaseUnaligned; uint8 *dic_CodeBase; union { cell *Cell; uint8 *Byte; } dic_CodePtr; uint8 *dic_CodeLimit; } cfDictionary; /* Save state of include when nesting files. */ typedef struct IncludeFrame { FileStream *inf_FileID; int32 inf_LineNumber; int32 inf_SourceNum; int32 inf_IN; char inf_SaveTIB[TIB_SIZE]; } IncludeFrame; #define MAX_INCLUDE_DEPTH (8) /*************************************************************** ** Prototypes ***************************************************************/ #ifdef __cplusplus extern "C" { #endif void pfExecuteToken( ExecToken XT ); #ifdef __cplusplus } #endif /*************************************************************** ** External Globals ***************************************************************/ extern cfTaskData *gCurrentTask; extern cfDictionary *gCurrentDictionary; extern char gScratch[TIB_SIZE]; extern int32 gNumPrimitives; extern ExecToken gLocalCompiler_XT; /* CFA of (LOCAL) compiler. */ #define DEPTH_AT_COLON_INVALID (-100) extern int32 gDepthAtColon; /* Global variables. */ extern char *gVarContext; /* Points to last name field. */ extern cell gVarState; /* 1 if compiling. */ extern cell gVarBase; /* Numeric Base. */ extern cell gVarEcho; /* Echo input from file. */ extern cell gVarEchoAccept; /* Echo input from ACCEPT. */ extern cell gVarTraceLevel; extern cell gVarTraceStack; extern cell gVarTraceFlags; extern cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ extern cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ /*************************************************************** ** 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_LONG_DIC(addr,data) WriteLongBigEndian((uint32 *)(addr),(uint32)(data)) #define WRITE_SHORT_DIC(addr,data) WriteShortBigEndian((uint16 *)(addr),(uint16)(data)) #define READ_FLOAT_DIC ReadFloatBigEndian #define READ_LONG_DIC(addr) ReadLongBigEndian((uint32 *)(addr)) #define READ_SHORT_DIC(addr) ReadShortBigEndian((uint16 *)(addr)) #elif defined(PF_LITTLE_ENDIAN_DIC) #define WRITE_FLOAT_DIC WriteFloatLittleEndian #define WRITE_LONG_DIC(addr,data) WriteLongLittleEndian((uint32 *)(addr),(uint32)(data)) #define WRITE_SHORT_DIC(addr,data) WriteShortLittleEndian((uint16 *)(addr),(uint16)(data)) #define READ_FLOAT_DIC ReadFloatLittleEndian #define READ_LONG_DIC(addr) ReadLongLittleEndian((uint32 *)(addr)) #define READ_SHORT_DIC(addr) ReadShortLittleEndian((uint16 *)(addr)) #else #define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); } #define WRITE_LONG_DIC(addr,data) { *((int32 *)(addr)) = (int32)(data); } #define WRITE_SHORT_DIC(addr,data) { *((int16 *)(addr)) = (int16)(data); } #define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) ) #define READ_LONG_DIC(addr) ( *((int32 *)(addr)) ) #define READ_SHORT_DIC(addr) ( *((int16 *)(addr)) ) #endif #define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell) #define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell) #define CODE_COMMA( N ) WRITE_LONG_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 *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_CodeLimit) ) #define IN_NAME_DIC(addr) ( ( ((uint8 *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_HeaderLimit) ) #define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr)) /* Address conversion */ #define ABS_TO_NAMEREL( a ) ((int32) (((uint8 *) a) - NAME_BASE )) #define ABS_TO_CODEREL( a ) ((int32) (((uint8 *) a) - CODE_BASE )) #define NAMEREL_TO_ABS( a ) ((char *) (((int32) a) + NAME_BASE)) #define CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CODE_BASE)) /* The check for >0 is only needed for CLONE testing. !!! */ #define IsTokenPrimitive(xt) ((xt=0)) #define SET_ABORT { gCurrentTask->td_Flags |= CFTD_FLAG_ABORT; } #define CLEAR_ABORT { gCurrentTask->td_Flags &= ~CFTD_FLAG_ABORT; } #define CHECK_ABORT (gCurrentTask->td_Flags & CFTD_FLAG_ABORT) #define FREE_VAR(v) { if (v) { pfFreeMem(v); v = NULL; } } #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) 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 DBUG(x) /* PRT(x) */ #define DBUGX(x) /* DBUG(x) */ #define MSG(cs) pfMessage(cs) #define ERR(x) MSG(x) #define MSG_NUM_D(msg,num) { MSG(msg); ffDot((int32) num); EMIT_CR; } #define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((int32) num); EMIT_CR; } #endif /* _pf_guts_h */ pforth-21/csrc/pf_host.h100664 1750 1750 1661 6510350772 14001 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ***************************************************************/ #endif /* _pf_system_h */ pforth-21/csrc/pf_inner.c100664 1750 1750 107560 6567307546 14214 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** ** 940502 PLB Creation. ** 940505 PLB More macros. ** 940509 PLB Moved all stack stuff into pfExecuteToken. ** 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 "pf_all.h" #define SYSTEM_LOAD_FILE "system.fth" /*************************************************************** ** Macros for data stack access. ** TOS is cached in a register in pfExecuteToken. ***************************************************************/ #define STKPTR (DataStackPtr) #define M_POP (*(STKPTR++)) #define M_PUSH(n) {*(--(STKPTR)) = (cell) (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) (n);} /*************************************************************** ** Misc Forth macros ***************************************************************/ #define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_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) &varname; } #define M_QUIT \ { \ ResetForthTask( ); \ LOAD_REGISTERS; \ } /*************************************************************** ** 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, int32 Level ) { char *DebugName; int32 i; if( ffTokenToName( Token, &DebugName ) ) { cell 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 *) (((int32) a) + CodeBase)) /**************************************************************/ void pfExecuteToken( ExecToken XT ) { register cell TopOfStack; /* Cache for faster execution. */ register cell *DataStackPtr; register cell *ReturnStackPtr; #ifdef PF_SUPPORT_FP register PF_FLOAT fpTopOfStack; PF_FLOAT *FloatStackPtr; register PF_FLOAT fpScratch; register PF_FLOAT fpTemp; #endif register cell *InsPtr = NULL; register cell Token; register cell Scratch; #ifdef PF_SUPPORT_TRACE register int32 Level = 0; #endif cell *LocalsPtr = NULL; cell Temp; cell *InitialReturnStack; cell FakeSecondary[2]; char *CharPtr; cell *CellPtr; FileStream *FileID; uint8 *CodeBase = CODE_BASE; /* ** 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; InitialReturnStack = TORPTR; Token = XT; do { DBUG(("pfExecuteToken: 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("pfExecuteToken: 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 *) ( LOCAL_CODEREL_TO_ABS(Token) ); /* Fetch token at IP. */ Token = READ_LONG_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. Put first in switch because ID_EXIT==0 */ case ID_EXIT: InsPtr = ( cell *) 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_LONG_DIC(InsPtr++); M_PUSH(READ_LONG_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: /* ( c-addr +n1 -- +n2 ) */ CharPtr = (char *) M_POP; TOS = ioAccept( CharPtr, TOS, PF_STDIN ); 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) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) ); endcase; /* Allocate some extra and put validation identifier at base */ #define PF_MEMORY_VALIDATOR (0xA81B4D69) case ID_ALLOCATE: CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); if( CellPtr ) { /* This was broken into two steps because different compilers incremented ** CellPtr before or after the XOR step. */ Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR; *CellPtr++ = Temp; M_PUSH( (cell) 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; /* Clear GO flag to tell QUIT to return. */ case ID_BYE: gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; endcase; case ID_BAIL: MSG("Emergency exit.\n"); EXIT(1); endcase; case ID_CALL_C: SAVE_REGISTERS; Scratch = READ_LONG_DIC(InsPtr++); CallUserFunction( Scratch & 0xFFFF, (Scratch >> 31) & 1, (Scratch >> 24) & 0x7F ); LOAD_REGISTERS; endcase; case ID_CFETCH: TOS = *((uint8 *) TOS); endcase; case ID_CMOVE: /* ( src dst n -- ) */ { register char *DstPtr = (char *) M_POP; /* dst */ CharPtr = (char *) M_POP; /* src */ for( Scratch=0; (uint32) Scratch < (uint32) 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; (uint32) Scratch < (uint32) TOS ; Scratch++ ) { *(--DstPtr) = *(--CharPtr); } M_DROP; } endcase; #ifndef PF_NO_SHELL case ID_COLON: ffColon( ); 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; int32 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 = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ; endcase; case ID_COMP_U_LESSTHAN: TOS = ( ((uint32)M_POP) < ((uint32)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: ffCreate(); endcase; #endif /* !PF_NO_SHELL */ case ID_CREATE_P: PUSH_TOS; /* Put address of body on stack. Insptr points after code start. */ TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET ); endcase; case ID_CSTORE: /* ( c caddr -- ) */ *((uint8 *) TOS) = (uint8) M_POP; M_DROP; endcase; /* Double precision add. */ case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ { register ucell 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 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; /* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ /* This seems crazy. There must be an easier way. !!! */ case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */ { register ucell a, b; register ucell pl, ph, mi; a = M_POP; b = TOS; ph = pl = 0; for( mi=0; mi<32; mi++ ) { /* Shift B to left, checking bits. */ /* Shift Product to left and add AP. */ ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ pl = pl << 1; if( b & 0x80000000 ) { register ucell temp; temp = pl + a; if( (temp < pl) || (temp < a) ) ph += 1; /* Carry */ pl = temp; } b = b << 1; DBUG(("UM* : mi = %d, a = 0x%08x, b = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, a, b, ph, pl )); } M_PUSH( pl ); TOS = ph; } endcase; /* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ /* This seems crazy. There must be an easier way. !!! */ case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ { register cell a, b; register ucell pl, ph, mi, ap, bp; a = M_POP; ap = (a < 0) ? -a : a ; /* Positive A */ b = TOS; bp = (b < 0) ? -b : b ; /* Positive B */ ph = pl = 0; for( mi=0; mi<32; mi++ ) { /* Shift B to left, checking bits. */ /* Shift Product to left and add AP. */ ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ pl = pl << 1; if( bp & 0x80000000 ) { register ucell temp; temp = pl + ap; if( (temp < pl) && (temp < ap) ) ph += 1; /* Carry */ pl = temp; } bp = bp << 1; DBUG(("M* : mi = %d, ap = 0x%08x, bp = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, ap, bp, ph, pl )); } /* Negate product if one operand negative. */ if( ((a ^ b) & 0x80000000) ) { pl = 0-pl; DBUG(("M* : -pl = 0x%08x\n", pl )); if( pl & 0x80000000 ) { ph = -1 - ph; /* Borrow */ } else { ph = 0 - ph; } DBUG(("M* : -ph = 0x%08x\n", ph )); } M_PUSH( pl ); TOS = ph; } endcase; #define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << 31); bh = bh >> 1; } if( !DULT(al,ah,bl,bh) ) { al = al - bl; q |= 1; } M_PUSH( al ); /* rem */ TOS = q; } endcase; /* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */ case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ { register ucell ah,am,al,ql,qh,di; #define bdiv ((ucell)TOS) ah = 0; am = M_POP; al = M_POP; qh = ql = 0; for( di=0; di<64; di++ ) { if( bdiv <= ah ) { ah = ah - bdiv; ql |= 1; } qh = (qh << 1) | (ql >> 31); ql = ql << 1; ah = (ah << 1) | (am >> 31); am = (am << 1) | (al >> 31); 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) '\n'; endcase; case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */ Scratch = TOS; M_DROP; if(TOS) { MSG_NUM_D("Error: ", (int32) Scratch); M_QUIT; } 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_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */ InsPtr = &FakeSecondary[0]; } else { InsPtr = (cell *) 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) READ_LONG_DIC((cell *)TOS); } else { TOS = *((cell *)TOS); } #else TOS = *((cell *)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 ) { pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Create file = %s\n", gScratch )); FileID = sdOpenFile( gScratch, PF_FAM_CREATE ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell) FileID ); } else { ERR("Filename too large for name buffer.\n"); M_PUSH( 0 ); 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 *fam; pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Open file = %s\n", gScratch )); fam = ( TOS == PF_FAM_READ_ONLY ) ? PF_FAM_OPEN_RO : PF_FAM_OPEN_RW ; FileID = sdOpenFile( gScratch, fam ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell) 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; Scratch = sdTellFile( FileID ); sdSeekFile( FileID, 0, PF_SEEK_END ); M_PUSH( sdTellFile( FileID )); sdSeekFile( FileID, Scratch, PF_SEEK_SET ); TOS = (Scratch < 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: /* ( pos fid -- ior ) */ FileID = (FileStream *) TOS; Scratch = M_POP; TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET ); endcase; case ID_FILE_POSITION: /* ( pos fid -- ior ) */ M_PUSH( sdTellFile( (FileStream *) TOS )); TOS = 0; 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_FILL: /* ( caddr num charval -- ) */ { register char *DstPtr; Temp = M_POP; /* num */ DstPtr = (char *) M_POP; /* dst */ for( Scratch=0; (uint32) Scratch < (uint32) 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) 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 *) TOS; CellPtr--; if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR)) { TOS = -2; /* FIXME error code */ } else { CellPtr[0] = 0xDeadBeef; CellPtr[1] = 0xDeadBeef; pfFreeMem((char *)CellPtr); TOS = 0; } } endcase; #include "pfinnrfp.h" case ID_HERE: PUSH_TOS; TOS = (cell)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) 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; ffIncludeFile( FileID ); LOAD_REGISTERS; #endif /* !PF_NO_SHELL */ endcase; 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_LONG_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 */ { int32 i = TOS; cell *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 *) 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; ffIncludeFile( FileID ); LOAD_REGISTERS; sdCloseFile( FileID ); } 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) NameToToken((ForthString *)TOS); endcase; case ID_NAME_TO_PREVIOUS: TOS = (cell) 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_LONG_DIC((cell *)TOS); Scratch += M_POP; WRITE_LONG_DIC((cell *)TOS,Scratch); } else { *((cell *)TOS) += M_POP; } #else *((cell *)TOS) += M_POP; #endif M_DROP; endcase; case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */ { ucell 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 implemented! */ PUSH_TOS; TOS = sdQueryTerminal(); endcase; case ID_QUIT_P: /* Stop inner interpreter, go back to user. */ #ifdef PF_SUPPORT_TRACE Level = 0; #endif ffAbort(); 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(); endcase; /* Resize memory allocated by ALLOCATE. */ case ID_RESIZE: /* ( addr1 u -- addr2 result ) */ { cell *FreePtr; FreePtr = (cell *) ( M_POP - sizeof(cell) ); if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR)) { M_PUSH( 0 ); TOS = -3; } else { /* Try to allocate. */ CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); if( CellPtr ) { /* Copy memory including validation. */ pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) ); *CellPtr++ = ((int32)CellPtr ^ PF_MEMORY_VALIDATOR); M_PUSH( (cell) ++CellPtr ); TOS = 0; FreePtr[0] = 0xDeadBeef; FreePtr[1] = 0xDeadBeef; pfFreeMem((char *) FreePtr); } else { M_PUSH( 0 ); 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)TORPTR; /* value before calling RP@ */ endcase; case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */ TORPTR = (cell *) TOS; M_DROP; endcase; case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */ { int32 ri; cell *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 ) */ { int32 NameSize, CodeSize, EntryPoint; CodeSize = TOS; NameSize = M_POP; EntryPoint = M_POP; ForthStringToC( gScratch, (char *) M_POP ); 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)STKPTR; endcase; case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ STKPTR = (cell *) 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_LONG_DIC((cell *)TOS,M_POP); } else { *((cell *)TOS) = M_POP; } #else *((cell *)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) CharPtr); endcase; #ifndef PF_NO_SHELL case ID_SEMICOLON: ffSemiColon( ); 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) CharPtr); endcase; case ID_SOURCE: /* ( -- c-addr num ) */ PUSH_TOS; M_PUSH( (cell) gCurrentTask->td_SourcePtr ); TOS = (cell) 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)ffConvertSourceIDToStream( TOS ); if( ffPushInputStream((FileStream *) TOS ) ) { M_QUIT; TOUCH(TOS); } 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; #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_QUIT; } 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.Cell); 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) 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) READ_SHORT_DIC((uint16 *)TOS); } else { TOS = *((uint16 *)TOS); } #else TOS = *((uint16 *)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 *)TOS,(uint16)M_POP); } else { *((uint16 *)TOS) = (uint16) M_POP; } #else *((uint16 *)TOS) = (uint16) 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("pfExecuteToken: Unrecognised token = 0x"); ffDotHex(Token); ERR(" at 0x"); ffDotHex((int32) InsPtr); EMIT_CR; InsPtr = 0; endcase; } if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */ #ifdef PF_DEBUG M_DOTS; #endif } while( (( InitialReturnStack - TORPTR) > 0 ) && (!CHECK_ABORT) ); SAVE_REGISTERS; } pforth-21/csrc/pf_io.c100664 1750 1750 10110 6510350772 13433 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ***************************************************************/ #include "pf_all.h" /*************************************************************** ** Send single character to output stream. */ void ioEmit( char c ) { int32 Result; Result = sdTerminalOut(c); if( Result < 0 ) EXIT(1); if(c == '\n') { gCurrentTask->td_OUT = 0; sdTerminalFlush(); } else { gCurrentTask->td_OUT++; } } void ioType( const char *s, int32 n ) { int32 i; for( i=0; i 0) { if( stream == PF_STDIN ) { c = ioKey(); /* If KEY does not echo, then echo here. If using getchar(), KEY will echo. */ #ifndef PF_KEY_ECHOS ioEmit( c ); if( c == '\r') ioEmit('\n'); /* Send LF after CR */ #endif } else { c = sdInputChar(stream); } switch(c) { case EOF: DBUG(("EOF\n")); return -1; break; case '\r': case '\n': *p++ = (char) c; DBUGX(("EOL\n")); goto gotline; break; case BACKSPACE: if( Len < MaxLen ) /* Don't go beyond beginning of line. */ { EMIT(' '); EMIT(BACKSPACE); p--; Len++; } break; default: *p++ = (char) c; Len--; break; } } gotline: *p = '\0'; return pfCStringLength( Target ); } #define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); } #ifdef PF_NO_CHARIO int sdTerminalOut( char c ) { TOUCH(c); return 0; } int sdTerminalIn( void ) { return -1; } int sdTerminalFlush( void ) { return -1; } #endif /***********************************************************************************/ #ifdef PF_NO_FILEIO /* Provide stubs for standard file I/O */ FileStream *PF_STDIN; FileStream *PF_STDOUT; int32 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; } int32 sdFlushFile( FileStream * Stream ) { TOUCH(Stream); return 0; } int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) { UNIMPLEMENTED("sdReadFile"); TOUCH(ptr); TOUCH(Size); TOUCH(nItems); TOUCH(Stream); return 0; } int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) { UNIMPLEMENTED("sdWriteFile"); TOUCH(ptr); TOUCH(Size); TOUCH(nItems); TOUCH(Stream); return 0; } int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ) { UNIMPLEMENTED("sdSeekFile"); TOUCH(Stream); TOUCH(Position); TOUCH(Mode); return 0; } int32 sdTellFile( FileStream * Stream ) { UNIMPLEMENTED("sdTellFile"); TOUCH(Stream); return 0; } int32 sdCloseFile( FileStream * Stream ) { UNIMPLEMENTED("sdCloseFile"); TOUCH(Stream); return 0; } #endif pforth-21/csrc/pf_io.h100664 1750 1750 7540 6510350772 13435 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef PF_NO_CHARIO int sdTerminalOut( char c ); int sdTerminalFlush( void ); int sdTerminalIn( void ); int sdQueryTerminal( 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 sdTerminalOut(c) putchar(c) #define sdTerminalIn getchar /* Since getchar() echos, define PF_KEY_ECHOS. */ #define PF_KEY_ECHOS /* * If you know a way to implement ?TERMINAL in STANDARD ANSI 'C', * please let me know. ?TERMINAL ( -- charAvailable? ) */ #define sdQueryTerminal() (0) #ifdef PF_NO_FILEIO #define sdTerminalFlush() /* fflush(PF_STDOUT) */ #else #define sdTerminalFlush() fflush(PF_STDOUT) #endif #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_CREATE ("w+") #define PF_FAM_OPEN_RO ("r") #define PF_FAM_OPEN_RW ("r+") #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 ); int32 sdFlushFile( FileStream * Stream ); int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ); int32 sdTellFile( FileStream * Stream ); int32 sdCloseFile( FileStream * Stream ); int32 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 sdFlushFile fflush #define sdReadFile fread #define sdWriteFile fwrite #define sdSeekFile fseek #define sdTellFile ftell #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 ioAccept( char *Target, cell n1, FileStream *Stream ); cell ioKey( void); void ioEmit( char c ); void ioType( const char *s, int32 n); #ifdef __cplusplus } #endif #endif /* _pf_io_h */ pforth-21/csrc/pf_mac.h100664 1750 1750 2157 6512451250 13560 0ustar bdalebdale/* @(#) pf_mac.h 98/01/26 1.2 */ #ifndef _pf_mac_h #define _pf_mac_h /*************************************************************** ** Macintosh dependant include file for PForth, a Forth based on 'C' ** ** 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 #include #include #include #ifdef PF_SUPPORT_FP #include #ifndef PF_USER_FP #include "pf_float.h" #else #include PF_USER_FP #endif #endif #endif /* _pf_mac_h */ pforth-21/csrc/pf_main.c100664 1750 1750 4143 6510350772 13741 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef PF_NO_STDIO #define NULL ((void *) 0) #define ERR(msg) /* { printf msg; } */ #else #include #define ERR(msg) { printf msg; } #endif #include "pforth.h" #ifdef __MWERKS__ #include #include #endif #ifndef TRUE #define TRUE (1) #define FALSE (0) #endif int main( int argc, char **argv ) { const char *DicName = "pforth.dic"; const char *SourceName = NULL; char IfInit = FALSE; char *s; int32 i; int Result; /* For Metroworks on Mac */ #ifdef __MWERKS__ argc = ccommand(&argv); #endif /* Parse command line. */ for( i=1; idlln_Previous) #define dllNextNode(n) ((n)->dlln_Next) void dllSetupList( DoublyLinkedList *dll ) { dll->dll_First = (DoublyLinkedListNode *) &(dll->dll_Null); dll->dll_Null = (DoublyLinkedListNode *) NULL; dll->dll_Last = (DoublyLinkedListNode *) &(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 ) )); } int32 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; static int32 gIfMemListInit; typedef struct MemListNode { DoublyLinkedListNode mln_Node; int32 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, int32 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( ( ((int32)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0) { MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (int32) 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. */ void pfInitMemAllocator( void *addr, uint32 poolSize ) { char *AlignedMemory; int32 AlignedSize; /* Set globals. */ gMemPoolPtr = addr; gMemPoolSize = poolSize; dllSetupList( &gMemList ); gIfMemListInit = TRUE; /* Adjust to next highest aligned memory location. */ AlignedMemory = (char *) ((((int32)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( int32 NumBytes ) { char *Mem = NULL; MemListNode *mln; if( NumBytes <= 0 ) return NULL; if( gIfMemListInit == 0 ) pfInitMemAllocator( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE ); /* 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 ) { int32 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( int32 NumBytes ) { int32 *IntMem; if( NumBytes <= 0 ) return NULL; /* Allocate an extra cell for size. */ NumBytes += sizeof(int32); IntMem = (int32 *)pfAllocRawMem( NumBytes ); if( IntMem != NULL ) *IntMem++ = NumBytes; return (char *) IntMem; } /*************************************************************** ** Free mem with mem size at first cell. */ void pfFreeMem( void *Mem ) { int32 *IntMem; int32 NumBytes; if( Mem == NULL ) return; /* Allocate an extra cell for size. */ IntMem = (int32 *) Mem; IntMem--; NumBytes = *IntMem; pfFreeRawMem( (char *) IntMem, NumBytes ); } #endif /* PF_NO_MALLOC */ pforth-21/csrc/pf_mem.h100664 1750 1750 2205 6512244224 13571 0ustar bdalebdale/* @(#) 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, Devid 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 pfInitMemAllocator( void *addr, uint32 poolSize ); char *pfAllocMem( int32 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 pfAllocMem malloc #define pfFreeMem free #endif #endif /* PF_NO_MALLOC */ #endif /* _pf_mem_h */ pforth-21/csrc/pf_save.c100664 1750 1750 44664 6577770400 14016 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** 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 ***************************************************************/ #include "pf_all.h" int IsHostLittleEndian( void ); /* If no File I/O, then force static dictionary. */ #ifdef PF_NO_FILEIO #ifndef PF_STATIC_DIC #define PF_STATIC_DIC #endif #endif #if 0 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) #endif /***************************************************************/ /* Endian-ness tools. */ uint32 ReadLongBigEndian( const uint32 *addr ) { const unsigned char *bp = (const unsigned char *) addr; return (bp[0]<<24) | (bp[1]<<16) | (bp[2]<<8) | bp[3]; } /***************************************************************/ uint16 ReadShortBigEndian( const uint16 *addr ) { const unsigned char *bp = (const unsigned char *) addr; return (uint16) ((bp[0]<<8) | bp[1]); } /***************************************************************/ uint32 ReadLongLittleEndian( const uint32 *addr ) { const unsigned char *bp = (const unsigned char *) addr; return (bp[3]<<24) | (bp[2]<<16) | (bp[1]<<8) | bp[0]; } /***************************************************************/ uint16 ReadShortLittleEndian( const uint16 *addr ) { const unsigned char *bp = (const unsigned char *) addr; return (uint16) ((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>24); bp[1] = (unsigned char) (data>>16); bp[2] = (unsigned char) (data>>8); bp[3] = (unsigned char) (data); } /***************************************************************/ void WriteShortBigEndian( uint16 *addr, uint16 data ) { unsigned char *bp = (unsigned char *) addr; bp[0] = (unsigned char) (data>>8); bp[1] = (unsigned char) (data); } /***************************************************************/ void WriteLongLittleEndian( uint32 *addr, uint32 data ) { unsigned char *bp = (unsigned char *) addr; bp[0] = (unsigned char) (data); bp[1] = (unsigned char) (data>>8); bp[2] = (unsigned char) (data>>16); bp[3] = (unsigned char) (data>>24); } /***************************************************************/ void WriteShortLittleEndian( uint16 *addr, uint16 data ) { unsigned char *bp = (unsigned char *) addr; bp[0] = (unsigned char) (data); bp[1] = (unsigned char) (data>>8); } /***************************************************************/ /* Return 1 if host CPU is Little Endian */ int IsHostLittleEndian( void ) { uint16 gEndianCheck = 1; unsigned char *bp = (unsigned char *) &gEndianCheck; return *bp; /* Return byte pointed to by address. If LSB then == 1 */ } #ifndef PF_STATIC_DIC #ifndef PF_NO_SHELL /***************************************************************/ static int32 WriteLong( FileStream *fid, int32 Val ) { int32 numw; uint32 pad; WriteLongBigEndian(&pad,Val); numw = sdWriteFile( (char *) &pad, 1, sizeof(int32), fid ); if( numw != sizeof(int32) ) return -1; return 0; } /***************************************************************/ static int32 WriteChunk( FileStream *fid, int32 ID, char *Data, int32 NumBytes ) { int32 numw; int32 EvenNumW; EvenNumW = EVENUP(NumBytes); if( WriteLong( fid, ID ) < 0 ) goto error; if( WriteLong( fid, EvenNumW ) < 0 ) goto error; numw = sdWriteFile( Data, 1, EvenNumW, fid ); if( numw != EvenNumW ) goto error; return 0; error: pfReportError("WriteChunk", PF_ERR_WRITE_FILE); return -1; } /**************************************************************** ** Save Dictionary in File. ** If EntryPoint is NULL, save as development environment. ** If EntryPoint is non-NULL, save as turnKey environment with no names. */ int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) { FileStream *fid; DictionaryInfoChunk SD; int32 FormSize; int32 NameChunkSize = 0; int32 CodeChunkSize; uint32 rhp, rcp; uint32 *p; int i; fid = sdOpenFile( FileName, "wb" ); if( fid == NULL ) { pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE); return -1; } /* Save in uninitialized form. */ pfExecByName("AUTO.TERM"); /* Write FORM Header ---------------------------- */ if( WriteLong( fid, ID_FORM ) < 0 ) goto error; if( WriteLong( fid, 0 ) < 0 ) goto error; if( WriteLong( fid, ID_P4TH ) < 0 ) goto error; /* Write P4DI Dictionary Info ------------------ */ SD.sd_Version = PF_FILE_VERSION; rcp = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */ SD.sd_RelCodePtr = rcp; SD.sd_UserStackSize = sizeof(cell) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit); SD.sd_ReturnStackSize = sizeof(cell) * (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_Reserved = 0; /* Set bit that specifiec 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 { /* Development mode. */ SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext); rhp = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr.Byte); SD.sd_RelHeaderPtr = rhp; /* How much real name space is there? */ NameChunkSize = QUADUP(rhp); /* 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(rcp); CodeSize = QUADUP(CodeSize); /* Align */ CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) ); SD.sd_CodeSize = CodeSize; /* Convert all fields in structure from Native to BigEndian. */ p = (uint32 *) &SD; for( i=0; i<((int)(sizeof(SD)/sizeof(int32))); i++ ) { WriteLongBigEndian( &p[i], p[i] ); } if( WriteChunk( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error; /* Write Name Fields if NameSize non-zero ------- */ if( NameSize > 0 ) { if( WriteChunk( fid, ID_P4NM, (char *) NAME_BASE, NameChunkSize ) < 0 ) goto error; } /* Write Code Fields ---------------------------- */ if( WriteChunk( fid, ID_P4CD, (char *) CODE_BASE, CodeChunkSize ) < 0 ) goto error; FormSize = sdTellFile( fid ) - 8; sdSeekFile( fid, 4, PF_SEEK_SET ); if( WriteLong( fid, FormSize ) < 0 ) goto error; sdCloseFile( fid ); /* Restore initialization. */ pfExecByName("AUTO.INIT"); return 0; error: sdSeekFile( fid, 0, PF_SEEK_SET ); WriteLong( fid, ID_BADF ); /* Mark file as bad. */ sdCloseFile( fid ); /* Restore initialization. */ pfExecByName("AUTO.INIT"); return -1; } #endif /* !PF_NO_SHELL */ /***************************************************************/ static int32 ReadLong( FileStream *fid, int32 *ValPtr ) { int32 numr; uint32 temp; numr = sdReadFile( &temp, 1, sizeof(int32), fid ); if( numr != sizeof(int32) ) return -1; *ValPtr = ReadLongBigEndian( &temp ); return 0; } /***************************************************************/ cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) { cfDictionary *dic = NULL; FileStream *fid; DictionaryInfoChunk *sd; int32 ChunkID; int32 ChunkSize; int32 FormSize; int32 BytesLeft; int32 numr; uint32 *p; int i; 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 (ReadLong( fid, &ChunkID ) < 0) goto read_error; if( ChunkID != ID_FORM ) { pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE); goto error; } if (ReadLong( fid, &FormSize ) < 0) goto read_error; BytesLeft = FormSize; if (ReadLong( 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 (ReadLong( fid, &ChunkID ) < 0) goto read_error; if (ReadLong( fid, &ChunkSize ) < 0) goto read_error; BytesLeft -= 8; DBUG(("ChunkID = %4s, Size = %d\n", &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; /* Convert all fields in structure from BigEndian to Native. */ p = (uint32 *) sd; for( i=0; i<((int)(sizeof(*sd)/sizeof(int32))); i++ ) { p[i] = ReadLongBigEndian( &p[i] ); } 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( (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_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 = (char *) NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */ gCurrentDictionary->dic_HeaderPtr.Byte = (uint8 *) NAMEREL_TO_ABS(sd->sd_RelHeaderPtr); } else { gVarContext = 0; gCurrentDictionary->dic_HeaderPtr.Byte = NULL; } gCurrentDictionary->dic_CodePtr.Byte = (uint8 *) 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 == NULL ) { 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( 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( 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 != NULL) { int32 Result; /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { pfReportError("pfLoadDictionary: FindSpecialXTs", Result); goto error; } } DBUG(("pfLoadDictionary: return 0x%x\n", dic)); return 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 /* PF_STATIC_DIC ============================================== */ /* ** Dictionary must come from data array because there is no file I/O. */ #ifndef HEADERPTR #include "pfdicdat.h" #endif int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) { TOUCH(FileName); TOUCH(EntryPoint); TOUCH(NameSize); TOUCH(CodeSize); pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED); return -1; } /***************************************************************/ cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) { cfDictionary *dic; int32 Result; int32 NewNameSize, NewCodeSize; MSG("pfLoadDictionary - Filename ignored! Loading from static data.\n"); TOUCH(FileName); TOUCH(EntryPointPtr); /* 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 if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) #endif { pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); goto error; } /* Static data too small. Copy it to larger array. */ #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; gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize ); if( !dic ) goto nomem_error; pfCopyMemory( dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) ); pfCopyMemory( dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) ); MSG("Static data copied to newly allocated dictionaries.\n"); dic->dic_CodePtr.Byte = (uint8 *) CODEREL_TO_ABS(CODEPTR); gNumPrimitives = NUM_PRIMITIVES; if( NAME_BASE != NULL) { /* Setup name space. */ dic->dic_HeaderPtr.Byte = (uint8 *) NAMEREL_TO_ABS(HEADERPTR); gVarContext = (char *) NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */ /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { pfReportError("pfLoadDictionary: FindSpecialXTs", Result); goto error; } } return dic; error: pfReportError("pfLoadDictionary", -1); return NULL; nomem_error: pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); return NULL; } #endif /* PF_STATIC_DIC */ pforth-21/csrc/pf_save.h100664 1750 1750 6277 6577770532 14007 0ustar bdalebdale/* @(#) 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, 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. ** ** 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 fileds must be the same size as int32 for easy endian conversion. */ int32 sd_Version; int32 sd_RelContext; /* relative ptr to Dictionary Context */ int32 sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */ int32 sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */ ExecToken sd_EntryPoint; /* relative ptr to entry point or NULL */ int32 sd_UserStackSize; /* in bytes */ int32 sd_ReturnStackSize; /* in bytes */ int32 sd_NameSize; /* in bytes */ int32 sd_CodeSize; /* in bytes */ int32 sd_NumPrimitives; /* To distinguish between primitive and secondary. */ uint32 sd_Flags; int32 sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */ uint32 sd_Reserved; } DictionaryInfoChunk; /* Bits in sd_Flags */ #define SD_F_BIG_ENDIAN_DIC (1<<0) #ifndef MAKE_ID #define MAKE_ID(a,b,c,d) ((a<<24)|(b<<16)|(c<<8)|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 int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize ); cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); /* Endian-ness tools. */ uint32 ReadLongBigEndian( const uint32 *addr ); uint16 ReadShortBigEndian( const uint16 *addr ); uint32 ReadLongLittleEndian( const uint32 *addr ); uint16 ReadShortLittleEndian( const uint16 *addr ); void WriteLongBigEndian( uint32 *addr, uint32 data ); void WriteShortBigEndian( uint16 *addr, uint16 data ); void WriteLongLittleEndian( uint32 *addr, uint32 data ); void WriteShortLittleEndian( uint16 *addr, uint16 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 */ pforth-21/csrc/pf_text.c100664 1750 1750 16372 6600016036 14020 0ustar bdalebdale/* @(#) 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, 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 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_BAD_ADDR & 0xFF: s = "address misaligned"; 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; default: s = "unrecognized error code!"; break; } MSG(s); EMIT_CR; } #endif /************************************************************** ** Copy a Forth String to a 'C' string. */ char *ForthStringToC( char *dst, const char *FString ) { int32 Len; Len = (int32) *FString; 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 ) { char *s; int32 i; s = dst+1; for( i=0; *CString; i++ ) { *s++ = *CString++; } *dst = (char ) i; return dst; } /************************************************************** ** Compare two test strings, case sensitive. ** Return TRUE if they match. */ int32 ffCompareText( const char *s1, const char *s2, int32 len ) { int32 i, Result; Result = TRUE; for( i=0; is2; */ int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ) { int32 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(int32)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */ static char cnttPad[CNTT_PAD_SIZE]; char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ) { int32 IfNegative = 0; char *p,c; uint32 NewNum, Rem, uNum; int32 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; int32 Len; FirstChar = Name+1; Len = *Name & 0x1F; ioType( FirstChar, Len ); } pforth-21/csrc/pf_text.h100664 1750 1750 5213 6567072706 14017 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #define PF_ERR_INDEX_MASK (0xFFFF) #define PF_ERR_BASE (0x80000000) #define PF_ERR_NO_MEM (PF_ERR_BASE | 0) #define PF_ERR_BAD_ADDR (PF_ERR_BASE | 1) #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) /* 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 ); char *ForthStringToC( char *dst, const char *FString ); char *CStringToForth( char *dst, const char *CString ); int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ); int32 ffCompareText( const char *s1, const char *s2, int32 len ); int32 ffCompareTextCaseN( const char *s1, const char *s2, int32 len ); void DumpMemory( void *addr, int32 cnt); char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ); void TypeName( const char *Name ); #ifdef __cplusplus } #endif #endif /* _pforth_text_h */ pforth-21/csrc/pf_types.h100664 1750 1750 3027 6510350774 14170 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ /*************************************************************** ** Type Declarations ***************************************************************/ #ifndef int32 typedef signed long int32; #endif #ifndef uint32 typedef unsigned long uint32; #endif #ifndef int16 typedef signed short int16; #endif #ifndef uint16 typedef unsigned short uint16; #endif #ifndef int8 typedef signed char int8; #endif #ifndef uint8 typedef unsigned char uint8; #endif #ifndef Err typedef long Err; #endif typedef uint32 ExecToken; /* Execution Token */ typedef int32 cell; typedef uint32 ucell; typedef cell *dicptr; typedef char ForthString; typedef char *ForthStringPtr; #endif /* _pf_types_h */ pforth-21/csrc/pf_unix.h100664 1750 1750 2410 6512451270 13775 0ustar bdalebdale/* @(#) pf_unix.h 98/01/28 1.4 */ #ifndef _pf_unix_h #define _pf_unix_h /*************************************************************** ** UNIX dependant include file for PForth, a Forth based on 'C' ** ** 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 #ifndef PF_NO_CLIB #include /* Needed for strlen(), memcpy(), and memset(). */ #include /* Needed for exit(). */ #endif #include /* Needed for FILE and getc(). */ #ifdef PF_SUPPORT_FP #include #ifndef PF_USER_FP #include "pf_float.h" #else #include PF_USER_FP #endif #endif #endif /* _pf_unix_h */ pforth-21/csrc/pf_win32.h100664 1750 1750 2335 6566653400 13772 0ustar bdalebdale/* @(#) pf_win32.h 98/01/26 1.2 */ #ifndef _pf_win32_h #define _pf_win32_h /*************************************************************** ** WIN32 dependant include file for PForth, a Forth based on 'C' ** ** 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 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+") #define LITTLE_ENDIAN #endif /* _pf_win32_h */ pforth-21/csrc/pf_words.c100664 1750 1750 10754 6567075164 14213 0ustar bdalebdale/* @(#) 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, 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. ** ** ** 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( int32 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( int32 n ) { MSG( ConvertNumberToText( n, 16, FALSE, 1 ) ); EMIT(' '); } /* ( ... --- ... , print stack ) */ void ffDotS( void ) { cell *sp; int32 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 ffScan( char *AddrIn, cell 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 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 ffNumberQ( const char *FWord, cell *Num ) { int32 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; int32 n1, n2, n3; int32 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]; } pforth-21/csrc/pf_words.h100664 1750 1750 2161 6510350774 14160 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif void ffDot( int32 n ); void ffDotHex( int32 n ); void ffDotS( void ); cell ffSkip( char *AddrIn, cell Cnt, char c, char **AddrOut ); cell ffScan( char *AddrIn, cell Cnt, char c, char **AddrOut ); #ifdef __cplusplus } #endif #endif /* _pforth_words_h */ pforth-21/csrc/pfcompfp.h100664 1750 1750 6241 6510350774 14152 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** ***************************************************************/ #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", 0 ); 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 pforth-21/csrc/pfcompil.c100664 1750 1750 74416 6577765716 14220 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** 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) /***************************************************************/ /************** GLOBAL DATA ************************************/ /***************************************************************/ /* data for INCLUDE that allows multiple nested files. */ static IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; static int32 gIncludeIndex; static ExecToken gNumberQ_XT; /* XT of NUMBER? */ static ExecToken gQuitP_XT; /* XT of (QUIT) */ /***************************************************************/ /************** Static Prototypes ******************************/ /***************************************************************/ static void ffStringColon( const ForthStringPtr FName ); static int32 CheckRedefinition( const ForthStringPtr FName ); static void ReportIncludeState( void ); static void ffUnSmudge( void ); static void FindAndCompile( const char *theWord ); static int32 ffCheckDicRoom( void ); static void ffCleanIncludeStack( void ); #ifndef PF_NO_INIT static void CreateDeferredC( ExecToken DefaultXT, const char *CName ); #endif int32 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, uint32 Flags ) { cfNameLinks *cfnl; cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr.Byte; /* Set link to previous header, if any. */ if( gVarContext ) { WRITE_LONG_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); } else { cfnl->cfnl_PreviousName = 0; } /* Put Execution token in header. */ WRITE_LONG_DIC( &cfnl->cfnl_ExecToken, XT ); /* Advance Header Dictionary Pointer */ gCurrentDictionary->dic_HeaderPtr.Byte += sizeof(cfNameLinks); /* Laydown name. */ gVarContext = (char *) gCurrentDictionary->dic_HeaderPtr.Byte; pfCopyMemory( gCurrentDictionary->dic_HeaderPtr.Byte, FName, (*FName)+1 ); gCurrentDictionary->dic_HeaderPtr.Byte += (*FName)+1; /* Set flags. */ *gVarContext |= (char) Flags; /* Align to quad byte boundaries with zeroes. */ while( ((uint32) gCurrentDictionary->dic_HeaderPtr.Byte) & 3) { *gCurrentDictionary->dic_HeaderPtr.Byte++ = 0; } } /*************************************************************** ** Convert name then create dictionary entry. */ void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ) { ForthString FName[40]; CStringToForth( FName, CName ); CreateDicEntry( XT, FName, Flags ); } /*************************************************************** ** Convert absolute namefield address to previous absolute name ** field address or NULL. */ const ForthString *NameToPrevious( const ForthString *NFA ) { cell RelNamePtr; const cfNameLinks *cfnl; /* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (int32) NFA)); */ cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); RelNamePtr = READ_LONG_DIC((const cell *) (&cfnl->cfnl_PreviousName)); /* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (int32) RelNamePtr )); */ if( RelNamePtr ) { return ( 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_LONG_DIC((const cell *) (&cfnl->cfnl_ExecToken)); } /*************************************************************** ** Find XTs needed by compiler. */ int32 FindSpecialXTs( void ) { if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind; if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind; DBUG(("gNumberQ_XT = 0x%x\n", gNumberQ_XT )); return 0; nofind: ERR("FindSpecialXTs failed!\n"); return -1; } /*************************************************************** ** Build a dictionary from scratch. */ #ifndef PF_NO_INIT cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ) { cfDictionary *dic; dic = pfCreateDictionary( HeaderSize, CodeSize ); if( !dic ) goto nomem; gCurrentDictionary = dic; gNumPrimitives = NUM_PRIMITIVES; CreateDicEntryC( ID_EXIT, "EXIT", 0 ); CreateDicEntryC( ID_1MINUS, "1-", 0 ); 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, "ACCEPT", 0 ); CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE ); CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 ); CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 ); 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_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 ); 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 ); CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 ); CreateDicEntryC( ID_DEFER, "DEFER", 0 ); CreateDicEntryC( ID_CSTORE, "C!", 0 ); CreateDicEntryC( ID_DEPTH, "DEPTH", 0 ); CreateDicEntryC( ID_DIVIDE, "/", 0 ); CreateDicEntryC( ID_DOT, ".", 0 ); CreateDicEntryC( ID_DOTS, ".S", 0 ); 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 ); CreateDeferredC( ID_EMIT_P, "EMIT"); 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_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_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_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 ); 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_TICK, "'", 0 ); CreateDicEntryC( ID_TIMES, "*", 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_VLIST, "VLIST", 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 ); 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 return dic; error: 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 ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) { const ForthString *NameField; int32 Searching = TRUE; cell Result = 0; ExecToken TempXT; NameField = 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 ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) { const ForthString *WordChar; uint8 WordLen; const char *NameField, *NameChar; int8 NameLen; int32 Searching = TRUE; cell Result = 0; WordLen = (uint8) ((uint32)*WordName & 0x1F); WordChar = WordName+1; NameField = gVarContext; DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); do { NameLen = (uint8) ((uint32)(*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 ffFind( const ForthString *WordName, ExecToken *pXT ) { const ForthString *NFA; int32 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 ffFindC( const char *WordName, ExecToken *pXT ) { DBUG(("ffFindC: %s\n", WordName )); CStringToForth( gScratch, WordName ); return ffFind( gScratch, pXT ); } /***********************************************************/ /********* Compiling New Words *****************************/ /***********************************************************/ #define DIC_SAFETY_MARGIN (400) /************************************************************* ** Check for dictionary overflow. */ static int32 ffCheckDicRoom( void ) { int32 RoomLeft; RoomLeft = gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderPtr.Byte; if( RoomLeft < DIC_SAFETY_MARGIN ) { pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM); return PF_ERR_HEADER_ROOM; } RoomLeft = gCurrentDictionary->dic_CodeLimit - 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) { /* Check for dictionary overflow. */ if( ffCheckDicRoom() ) return; CheckRedefinition( FName ); /* Align CODE_HERE */ CODE_HERE = (cell *)( (((uint32)CODE_HERE) + 3) & ~3); CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE ); DBUG(("ffCreateSecondaryHeader, XT = 0x%x, Name = %8s\n")); } /************************************************************* ** 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 int32 CheckRedefinition( const ForthStringPtr FName ) { int32 Flag; ExecToken XT; Flag = ffFind( FName, &XT); if( Flag ) { ioType( FName+1, (int32) *FName ); MSG( " already defined.\n" ); } 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 ) { 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 ); 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 ) { *gVarContext &= ~FLAG_SMUDGE; } /* Implement ; */ void ffSemiColon( void ) { gVarState = 0; if( (gDepthAtColon != DATA_STACK_DEPTH) && (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ { pfReportError("ffSemiColon", PF_ERR_COLON_STACK); ffAbort(); } else { ffFinishSecondary(); } gDepthAtColon = DEPTH_AT_COLON_INVALID; } /* 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 dHi, cell dLo ) { CODE_COMMA( ID_2LITERAL_P ); CODE_COMMA( dHi ); CODE_COMMA( dLo ); } void ffALiteral( cell Num ) { CODE_COMMA( ID_ALITERAL_P ); CODE_COMMA( Num ); } void ffLiteral( cell 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 *dicPtr; /* Make sure that literal float data is float aligned. */ dicPtr = CODE_HERE + 1; while( (((uint32) 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 *) temp; } #endif /* PF_SUPPORT_FP */ /**************************************************************/ void FindAndCompile( const char *theWord ) { int32 Flag; ExecToken XT; cell Num; 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 { pfExecuteToken( XT ); } } else if ( Flag == 1 ) /* or is it IMMEDIATE ? */ { DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); pfExecuteToken( XT ); } else /* try to interpret it as a number. */ { /* Call deferred NUMBER? */ int32 NumResult; DBUG(("FindAndCompile: not found, try number?\n" )); PUSH_DATA_STACK( theWord ); /* Push text of number */ pfExecuteToken( gNumberQ_XT ); 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" ); ffAbort( ); break; } } } /************************************************************** ** Forth outer interpreter. Parses words from Source. ** Executes them or compiles them based on STATE. */ int32 ffInterpret( void ) { int32 Flag; char *theWord; /* Is there any text left in Source ? */ while( (gCurrentTask->td_IN < (gCurrentTask->td_SourceNum-1) ) && !CHECK_ABORT) { DBUGX(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN, gCurrentTask->td_SourceNum ) ); theWord = ffWord( BLANK ); DBUGX(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); if( *theWord > 0 ) { Flag = 0; if( gLocalCompiler_XT ) { PUSH_DATA_STACK( theWord ); /* Push word. */ pfExecuteToken( gLocalCompiler_XT ); Flag = POP_DATA_STACK; /* Compiled local? */ } if( Flag == 0 ) { FindAndCompile( theWord ); } } } DBUG(("ffInterpret: CHECK_ABORT = %d\n", CHECK_ABORT)); return( CHECK_ABORT ? -1 : 0 ); } /**************************************************************/ void ffOK( void ) { /* Check for stack underflow. %Q what about overflows? */ if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 ) { MSG("Stack underflow!\n"); ResetForthTask( ); } #ifdef PF_SUPPORT_FP /* Check floating point stack too! */ else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0) { MSG("FP stack underflow!\n"); ResetForthTask( ); } #endif else if( gCurrentTask->td_InputStream == PF_STDIN) { if( !gVarState ) /* executing? */ { if( !gVarQuiet ) { MSG( " ok\n" ); if(gVarTraceStack) ffDotS(); } else { EMIT_CR; } } } } /*************************************************************** ** Report state of include stack. ***************************************************************/ static void ReportIncludeState( void ) { int32 i; /* If not INCLUDing, just return. */ if( gIncludeIndex == 0 ) return; /* Report line number and nesting level. */ MSG_NUM_D("INCLUDE error on line #", gCurrentTask->td_LineNumber ); MSG_NUM_D("INCLUDE nesting level = ", gIncludeIndex ); /* Dump line of error and show offset in line for >IN */ MSG( gCurrentTask->td_SourcePtr ); for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^'); EMIT_CR; } /*************************************************************** ** Interpret input in a loop. ***************************************************************/ void ffQuit( void ) { gCurrentTask->td_Flags |= CFTD_FLAG_GO; while( gCurrentTask->td_Flags & CFTD_FLAG_GO ) { if(!ffRefill()) { /* gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; */ return; } ffInterpret(); DBUG(("gCurrentTask->td_Flags = 0x%x\n", gCurrentTask->td_Flags)); if(CHECK_ABORT) { CLEAR_ABORT; } else { ffOK( ); } } } /*************************************************************** ** Include a file ***************************************************************/ cell ffIncludeFile( FileStream *InputFile ) { cell Result; /* Push file stream. */ Result = ffPushInputStream( InputFile ); if( Result < 0 ) return Result; /* Run outer interpreter for stream. */ ffQuit(); /* Pop file stream. */ ffPopInputStream(); return gVarReturnCode; } #endif /* !PF_NO_SHELL */ /*************************************************************** ** Save current input stream on stack, use this new one. ***************************************************************/ Err ffPushInputStream( FileStream *InputFile ) { cell 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 ffConvertStreamToSourceID( FileStream *Stream ) { cell Result; if(Stream == PF_STDIN) { Result = 0; } else if(Stream == NULL) { Result = -1; } else { Result = (cell) Stream; } return Result; } /*************************************************************** ** Convert file pointer to value consistent with SOURCE-ID. ***************************************************************/ FileStream * ffConvertSourceIDToStream( cell id ) { FileStream *stream; if( id == 0 ) { stream = PF_STDIN; } else if( id == -1 ) { stream = NULL; } else { stream = (FileStream *) id; } return stream; } /*************************************************************** ** Cleanup Include stack by popping and closing files. ***************************************************************/ static void ffCleanIncludeStack( void ) { FileStream *cur; while( (cur = ffPopInputStream()) != PF_STDIN) { DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); sdCloseFile(cur); } } /**************************************************************/ void ffAbort( void ) { #ifndef PF_NO_SHELL ReportIncludeState(); #endif /* PF_NO_SHELL */ ffCleanIncludeStack(); ResetForthTask(); SET_ABORT; if( gVarReturnCode == 0 ) gVarReturnCode = ABORT_RETURN_CODE; } /**************************************************************/ /* ( -- , fill Source from current stream ) */ /* Return FFALSE if no characters. */ cell ffRefill( void ) { cell Num, Result = FTRUE; /* get line from current stream */ Num = ioAccept( gCurrentTask->td_SourcePtr, TIB_SIZE, gCurrentTask->td_InputStream ); if( Num < 0 ) { Result = FFALSE; Num = 0; } /* reset >IN for parser */ gCurrentTask->td_IN = 0; gCurrentTask->td_SourceNum = Num; gCurrentTask->td_LineNumber++; /* Bump for include. */ /* echo input if requested */ if( gVarEcho && ( Num > 0)) { MSG( gCurrentTask->td_SourcePtr ); } return Result; } pforth-21/csrc/pfcompil.h100664 1750 1750 5031 6510350774 14145 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif Err ffPushInputStream( FileStream *InputFile ); ExecToken NameToToken( const ForthString *NFA ); FileStream * ffConvertSourceIDToStream( cell id ); FileStream *ffPopInputStream( void ); cell ffConvertStreamToSourceID( FileStream *Stream ); cell ffFind( const ForthString *WordName, ExecToken *pXT ); cell ffFindC( const char *WordName, ExecToken *pXT ); cell ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ); cell ffIncludeFile( FileStream *InputFile ); cell ffNumberQ( const char *FWord, cell *Num ); cell ffRefill( void ); cell ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); cell *NameToCode( ForthString *NFA ); cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); char *ffWord( char c ); const ForthString *NameToPrevious( const ForthString *NFA ); int32 FindSpecialCFAs( void ); int32 FindSpecialXTs( void ); int32 NotCompiled( const char *FunctionName ); int32 ffInterpret( void ); void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, uint32 Flags ); void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ); void ff2Literal( cell dHi, cell dLo ); void ffALiteral( cell Num ); void ffAbort( void ); void ffColon( void ); void ffCreate( void ); void ffCreateSecondaryHeader( const ForthStringPtr FName); void ffDefer( void ); void ffFinishSecondary( void ); void ffLiteral( cell Num ); void ffOK( void ); void ffQuit( void ); void ffSemiColon( void ); void ffStringCreate( ForthStringPtr FName); void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ); #ifdef PF_SUPPORT_FP void ffFPLiteral( PF_FLOAT fnum ); #endif #ifdef __cplusplus } #endif #endif /* _pforth_compile_h */ pforth-21/csrc/pfcustom.c100664 1750 1750 7320 6600014662 14163 0ustar bdalebdale/* @(#) 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, 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 "pf_all.h" static int32 CTest0( int32 Val ); static void CTest1( int32 Val1, cell Val2 ); /**************************************************************** ** Step 1: Put your own special glue routines here ** or link them in from another file or library. ****************************************************************/ static int32 CTest0( int32 Val ) { MSG_NUM_D("CTest0: Val = ", Val); return Val+1; } static void CTest1( int32 Val1, cell 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) void *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. */ void *CustomFunctionTable[] = { (void *)CTest0, (void *)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; /* 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", 0, C_RETURNS_VALUE, 1 ); if( err < 0 ) return err; err = CreateGlueToC( "CTEST1", 1, 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" ** Test: 10 Ctest0 ( should print message then '11' ) ****************************************************************/ #endif /* PF_USER_CUSTOM */ pforth-21/csrc/pfinnrfp.h100664 1750 1750 20610 6577765104 14210 0ustar bdalebdale/* @(#) 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, 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. ** **************************************************************** ** ***************************************************************/ #ifdef PF_SUPPORT_FP #define FP_DHI1 (((PF_FLOAT)0x40000000)*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) ((unsigned int)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); */ { uint32 dlo; int32 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 = (int32) fpScratch; /* dhi */ fpScratch = ((PF_FLOAT) dhi) * FP_DHI1; /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */ fpTemp = fpTemp - fpScratch; /* Remainder */ dlo = (uint32) 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 *) fptr; } #endif endcase; case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_log(FP_TOS); break; case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0); break; case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_log10( FP_TOS ); break; case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sin( FP_TOS ); break; case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */ M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS)); FP_TOS = (PF_FLOAT) fp_cos(FP_TOS); break; case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS ); break; case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS ); break; case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_tan( FP_TOS ); break; case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS ); break; case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */ PUSH_FP_TOS; /* push cached floats into RAM */ FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */ M_DROP; break; #endif pforth-21/csrc/pforth.h100664 1750 1750 5221 6510350774 13637 0ustar bdalebdale/* @(#) 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, 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. ** ** ***************************************************************/ /* Define stubs for data types so we can pass pointers but not touch inside. */ typedef struct cfTaskData cfTaskData; typedef struct cfDictionary cfDictionary; typedef unsigned long ExecToken; /* Execution Token */ #ifndef int32 typedef long int32; #endif #ifdef __cplusplus extern "C" { #endif /* Main entry point to pForth. */ int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); /* Turn off messages. */ void pfSetQuiet( int32 IfQuiet ); /* Query message status. */ int32 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. */ cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); /* Establish this task as the current task. */ void pfSetCurrentTask( cfTaskData *cftd ); /* Delete task created by pfCreateTask */ void pfDeleteTask( cfTaskData *cftd ); /* Build a dictionary with all the basic kernel words. */ cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); /* Create an empty dictionary. */ cfDictionary *pfCreateDictionary( int32 HeaderSize, int32 CodeSize ); /* Load dictionary from a file. */ cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); /* Delete dictionary data. */ void pfDeleteDictionary( cfDictionary *dic ); /* Execute the pForth interpreter. */ int32 pfRunForth( void ); /* Execute a single execution token in the current task. */ void pfExecuteToken( ExecToken XT ); /* Include the given pForth source code file. */ int32 pfIncludeFile( const char *FileName ); /* Execute a Forth word by name. */ void pfExecByName( const char *CString ); #ifdef __cplusplus } #endif #endif /* _pforth_h */ pforth-21/csrc/pf_all.h100664 1750 1750 3162 6541253346 13575 0ustar bdalebdale/* @(#) 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, 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. ** ** 940521 PLB Creation. ** ***************************************************************/ /* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */ #ifdef __MWERKS__ #define PF_USER_INC1 "pf_mac.h" #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 /* Default to UNIX if no host speciied. */ #include "pf_unix.h" #endif #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 */ pforth-21/csrc/pf_float.h100664 1750 1750 2474 6512451216 14131 0ustar bdalebdale/* @(#) 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, 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. ** ***************************************************************/ 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 pforth-21/docs/ 40775 1750 1750 0 6462156704 12070 5ustar bdalebdalepforth-21/docs/pf_ref.htm100664 1750 1750 153600 6567353534 14213 0ustar bdalebdale pForth Reference

pForth Reference Manual

pForth - a Portable ANSI style Forth written in ANSI 'C'.  Last updated: August 20th, 1998 V20

by Phil Burk with Larry Polansky, David Rosenboom. Special thanks to contributors Darren Gibbs, Herb Maeder, Gary Arakaki, Mike Haas.

PForth source code is freely available.  The author is available for customization of pForth, porting to new platforms, or developing pForth applications on a contractual basis.  If interested, contact  Phil Burk at philburk@softsynth.com

Back to pForth Home Page

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.

Table of Contents

What is pForth?

PForth is an ANSI style Forth designed to be portable across many platforms. The 'P' in pForth stands for "Portable". PForth is based on a Forth kernel written in ANSI standard 'C'.

What is Forth?

Forth is a stack based language invented by astronomer Charles Moore for controlling telescopes. Forth is an interactive language. You can enter commands at the keyboard and have them be immediately executed, similar to BASIC or LISP. Forth has a dictionary of words that can be executed or used to construct new words that are then added to the dictionary. Forth words operate on a data stack that contains numbers and addresses.

To learn more about Forth, see the Forth Tutorial.

The Origins of pForth

PForth began as a JSR threaded 68000 Forth called HForth that was used to support HMSL, the Hierarchical Music Specification Language. HMSL was a music experimentation language developed by Phil Burk, Larry Polansky and David Rosenboom while working at the Mills College Center for Contemporary Music. Phil moved from Mills to the 3DO Company where he ported the Forth kernel to 'C'. It was used at 3DO as a tool for verifying ASIC design and for bringing up new hardware platforms. At 3DO, the Forth had to run on many systems including SUN, SGI, Macintosh, PC, Amiga, the 3DO ARM based Opera system, and the 3DO PowerPC based M2 system. PForth is now being developed for use at CagEnt, a spinoff of 3DO.

pForth Design Goals

PForth has been designed with portability as the primary design goal. As a result, pForth avoids any fancy UNIX calls. pForth also avoids using any clever and original ways of constructing the Forth dictionary. It just compiles its kernel from ANSI compatible 'C' code then loads ANS compatible Forth code to build the dictionary. Very boring but very likely to work on almost any platform.

The dictionary files that can be saved from pForth are almost host independant. They can be compiled on one processor, and then run on another processor. as long as the endian-ness is the same. In other words, dictionaries built on a PC will only work on a PC. Dictionaries built on almost any other computer will work on almost any other computer.

PForth can be used to bring up minimal hardware systems that have very few system services implemented. It is possible to compile pForth for systems that only support routines to send and receive a single character. If malloc() and free() are not available, equivalent functions are available in standard 'C' code. If file I/O is not available, the dictionary can be saved as a static data array in 'C' source format on a host system. The dictionary in 'C' source form is then compiled with a custom pForth kernel to avoid having to read the dictionary from disk.

Compiling pForth for your System

The process of building pForth involves several steps. This process is typically handled automatically by the Makefile or IDE Project.
  1. Compile the 'C' based pForth kernel called "pforth".
  2. Execute "pforth" with the -i option to build the dictionary from scratch.
  3. Compile the "system.fth" file which will add all the top level Forth words.
  4. Save the compiled dictionary as "pforth.dic".
  5. The next time you run pforth, the precompiled pforth.dic file will be loaded automatically.

UNIX

A Makefile has been provided that should work on most UNIX platforms.
  1. cd to top directory of pForth
  2. Enter: make all

Macintosh

A precompiled PPC binary for pForth is provided. A Code Warrior Project has been provided that will rebuild pForth for PPC if desired. Alternatively you could use MPW to make pForth as an MPW Tool.  Make sure that you provide at least 1 Meg of heap space. If you build for 68K, make sure you use 32 bit integers, and select the appropriate libraries.  To rebuild pForth for PPC:
  1. Open pForthCW
  2. Make target "pForthApp"
  3. Run pForthApp
  4. Enter "-i" as Argumant in starting dialog to initialize dictionary.
  5. To compile system.fth, enter "loadsys".
  6. Quit pForth using File menu.
  7. From now on, just double click pForthApp icon to run pForth.

PC Compatible

A precompiled binary for pForth is provided. To rebuild under Windows NT or Win95 using Microsoft Visual C++:
  1. Double click on the pForth.dsw icon in "pForth\pcbuild".
  2. Select the "MakeDic" configuration.
  3. Select "Rebuild All" from the Build menu.This will build the pForth.exe file.
  4. Run the app with CTRL-F5 which will build the pforth.dic file.
  5. Select the "Release" configuration.
  6. Run the app with CTRL-F5 which will drop you into Forth.
  7. From now on, to run pForth, just double click on the pforth.exe file.

Description of Source Files

Forth Source

ansilocs.fth    = support for ANSI (LOCAL) word
c_struct.fth    = 'C' like data structures
case.fth        = CASE OF ENDOF ENDCASE
catch.fth       = CATCH and THROW
condcomp.fth    = [IF] [ELSE] [THEN] conditional compiler
filefind.fth    = FILE?
floats.fth      = floating point support
forget.fth      = FORGET [FORGET] IF.FORGOTTEN
loadp4th.fth    = loads basic dictionary
locals.fth      = { } style locals using (LOCAL)
math.fth        = misc math words
member.fth      = additional 'C' like data structure support
misc1.fth       = miscellaneous words
misc2.fth       = miscellaneous words
numberio.fth    = formatted numeric input/output
private.fth     = hide low level words
quit.fth        = QUIT EVALUATE INTERPRET in high level
smart_if.fth    = allows conditionals outside colon definition
see.fth         = Forth "disassembler".  Eg.  SEE SPACES
strings.fth     = string support
system.fth      = bootstraps pForth dictionary
trace.fth       = single step trace for debugging

'C' Source

csrc/pfcompil.c = pForth compiler support
csrc/pfcustom.c = example of 'C' functions callable from pForth
csrc/pfinnrfp.h = float extensions to interpreter
csrc/pforth.h = include this in app that embeds pForth
csrc/pf_cglue.c = glue for pForth calling 'C'
csrc/pf_clib.c = replacement routines for 'C' stdlib
csrc/pf_core.c = primary words called from 'C' app that embeds pForth
csrc/pf_float.h = defines PF_FLOAT, and the floating point math functions such as fp_sin
csrc/pf_inner.c = inner interpreter
csrc/pf_guts.h = primary include file, define structures
csrc/pf_io.c = input/output
csrc/pf_main.c = basic application for standalone pForth
csrc/pf_mem.c = optional malloc() implementation
csrc/pf_save.c = save and load dictionaries
csrc/pf_text.c = string tools, error message text
csrc/pf_words.c = miscellaneous pForth words implemented

Running pForth

PForth can be run from a shell or by double clicking on its icon, depending on the system you are using. The execution options for pForth are described assuming that you are running it from a shell.

Usage: 

    pforth [-i] [-dDictionaryFilename] [SourceFilename]
-i
Initialize pForth by building dictionary from scratch. Used when building pForth or when debugging pForth on new systems.
-dDictionaryFilename
Specify a custom dictionary to be loaded in place of the default "pforth.dic". For example:
      pforth -dgame.dic
SourceFilename
A Forth source file can be automatically compiled by passing its name to pForth. This is useful when using Forth as an assembler or for automated hardware testing. Remember that the source file can compile code and execute it all in the same file.

Quick Verification of pForth

To verify that PForth is working, enter: 
    3 4 + .
It should print "7 ok". Now enter:
    WORDS
You should see a long list of all the words in the pForth dictionary. Don't worry. You won't need to learn all of these.  More tests are described in the README.txt file.

ANSI Compliance

This Forth is intended to be ANS compatible. I will not claim that it is compatible until more people bang on it. If you find areas where it deviates from the standard, please let me know.

Word sets supported include:

  • FLOAT
  • LOCAL with support for { lv1 lv2 | lv3 -- } style locals
  • EXCEPTION but standard throw codes not implemented
  • FILE ACCESS
  • MEMORY ALLOCATION
Here are the areas that I know are not compatible:

The ENVIRONMENT queries are not implemented.

Word sets NOT supported include:

  • BLOCK - a matter of religion
  • SEARCH ORDER - coming soon
  • PROGRAMMING TOOLS - only has .S ? DUMP WORDS BYE
  • STRING - only has CMOVE CMOVE> COMPARE
  • DOUBLE NUMBER - but cell is 32 bits

pForth Special Features

These features are not part of the ANS standard for Forth.  They have been added to assist developers.

Compiling from a File

Use INCLUDE to compile source code from a file: 
    INCLUDE filename
You can nest calls to INCLUDE. INCLUDE simply redirects Forth to takes its input from the file instead of the keyboard so you can place any legal Forth code in the source code file.

Saving Precompiled Dictionaries

Use SAVE-FORTH save your precompiled code to a file. To save the current dictionary to a file called "custom.dic", enter: 
    c" custom.dic" SAVE-FORTH
You can then leave pForth and use your custom dictionary by enterring: 
    pforth -dcustom.dic
On icon based systems, you may wish to name your custom dictionary "pforth.dic" so that it will be loaded automatically.

Be careful that you do not leave absolute addresses stored in the dictionary because they will not work when you reload pForth at a different address. Use A! to store an address in a variable in a relocatable form and A@ to get it back if you need to. 

    VARIABLE DATA-PTR
CREATE DATA 100 ALLOT
DATA DATA-PTR !    \ storing absolute address!  BAD
DATA DATA-PTR A!   \ storing relocatable address!  GOOD
DATA-PTR A@        \ fetch relocatable address

Recompiling Code - ANEW INCLUDE?

When you are testing a file full of code, you will probably recompile many times. You will probably want to FORGET the old code before loading the new code. You could put a line at the beginning of your file like this: 
    FORGET XXXX-MINE     : XXXX-MINE ;
This would automatically FORGET for you every time you load. Unfortunately, you must define XXXX-MINE before you can ever load this file. We have a word that will automatically define a word for you the first time, then FORGET and redefine it each time after that. It is called ANEW and can be found at the beginning of most Forth source files. We use a prefix of TASK- followed by the filename just to be consistent. This TASK-name word is handy when working with INCLUDE? as well. Here is an example: 
    \ Start of file
INCLUDE? TASK-MYTHING.FTH MYTHING.FTH
ANEW TASK-THISFILE.FTH
\ the rest of the file follows...
Notice that the INCLUDE? comes before the call to ANEW so that we don't FORGET MYTHING.FTH every time we recompile.

FORGET allows you to get rid of code that you have already compiled. This is an unusual feature in a programming language. It is very convenient in Forth but can cause problems. Most problems with FORGET involve leaving addresses that point to the forgotten code that are not themselves forgotten. This can occur if you set a deferred system word to your word then FORGET your word. The system word which is below your word in the dictionary is pointing up to code that no longer exists. It will probably crash if called. (See discussion of DEFER below.) Another problem is if your code allocates memory, opens files, or opens windows. If your code is forgotten you may have no way to free or close these thing. You could also have a problems if you add addresses from your code to a table that is below your code. This might be a jump table or data table.

Since this is a common problem we have provided a tool for handling it. If you have some code that you know could potentially cause a problem if forgotten, then write a cleanup word that will eliminate the problem. This word could UNdefer words, free memory, etc. Then tell the system to call this word if the code is forgotten. Here is how: 

    : MY.CLEANUP  ( -- , do whatever )
    MY-MEM @ FREE DROP
    0 MY-MEM !
;
IF.FORGOTTEN  MY.CLEANUP
IF.FORGOTTEN creates a linked list node containing your CFA that is checked by FORGET. Any nodes that end up above HERE (the Forth pointer to the top of the dictionary) after FORGET is done are executed.

Customising FORGET with [FORGET]

Sometimes, you may need to extend the way that FORGET works. FORGET is not deferred, however, because that could cause some real problems. Instead, you can define a new version of [FORGET] which is searched for and executed by FORGET. You MUST call [FORGET] from your program or FORGET will not actually FORGET. Here is an example. 
    : [FORGET]  ( -- , my version )
    ." Change things around!" CR
    [FORGET]  ( must be called )
    ." Now put them back!" CR
;
: FOO ." Hello!" ;
FORGET FOO  ( Will print "Change things around!", etc.)
This is recommended over redefining FORGET because words like ANEW that call FORGET will now pick up your changes.

Smart Conditionals

In pForth, you can use IF THEN DO LOOP and other conditionals outside of colon definitions. PForth will switch temporarily into the compile state, then automatically execute the conditional code. (Thank you Mitch Bradley) For example, just enter this at the keyboard. 
    10 0 DO I . LOOP

Development Tools

WORDS.LIKE

If you cannot remember the exact name of a word, you can use WORDS.LIKE to search the dictionary for all words that contain a substring. For an example, enter: 
    WORDS.LIKE   FOR
WORDS.LIKE   EMIT

FILE?

You can use FILE? to find out what file a word was compiled from. If a word was defined in multiple files then it will list each file. The execution token of each definition of the word is listed on the same line.
    FILE? IF
    FILE? AUTO.INIT

SEE

You can use SEE to "disassemble" a word in the pForth dictionary. SEE will attempt to print out Forth source in a form that is similar to the source code. SEE will give you some idea of how the word was defined but is not perfect. Certain compiler words, like BEGIN and LITERAL, are difficult to disassemble and may not print properly. For an example, enter: 
    SEE SPACES
SEE WORDS

Single Step Trace and Debug

It is often useful to proceed step by step through your code when debugging.  PForth provides a simple single step trace facility for this purpose.  Here is an example of using TRACE to debug a simple program.  Enter the following program:
  
    : SQUARE ( n -- n**2 )
    DUP  *
;
: TSQ  ( n -- , test square )
    ." Square of "   DUP   .
    ." is "   SQUARE   .   CR
;
Even though this program should work, let's pretend it doesn't and try to debug it.  Enter:
    7  TRACE  TSQ
You should see: 
    7 trace tsq
<<  TSQ +0           <10:1> 7             ||  (.")  Square of "          >>    ok
The "TSQ +0" means that you are about to execute code at an offset of "+0" from the beginning of TSQ.  The <10:1> means that we are in base 10, and that there is 1 item on the stack, which is shown to be "7". The (.") is the word that is about to be executed.  (.") is the word that is compiled when use use .".  Now to single step, enter: 
    s
You should see: 
    Square of
<<  TSQ +16          <10:1> 7             ||  DUP                         >>    ok
The "Square os" was printed by (."). We can step multiple times using the "sm" command. Enter:
    3 sm
You should see: 
    <<  TSQ +20          <10:2> 7 7           ||  .                         >> 7 
<<  TSQ +24          <10:1> 7             ||  (.")  is "                >> is 
<<  TSQ +32          <10:1> 7             ||  SQUARE                    >>    ok
The "7" after the ">>" was printed by the . word. If we entered "s", we would step over the SQUARE word. If we want to dive down into SQUARE, we can enter: 
    sd
You should see:
    <<  SQUARE +0        <10:1> 7             ||    DUP                     >>    ok
To step once in SQUARE, enter:
    s
You should see: 
    <<  SQUARE +4        <10:2> 7 7           ||    *                        >>    ok
To go to the end of the current word, enter:
    g
You should see:
    <<  SQUARE +8        <10:1> 49            ||    EXIT                      >> 
<<  TSQ +36          <10:1> 49            ||  .                           >>    ok
EXIT is compiled at the end of every Forth word. For more information on TRACE, enter TRACE.HELP: 
    TRACE  ( i*x <name> -- , setup trace for Forth word )
S      ( -- , step over )
SM     ( many -- , step over many times )
SD     ( -- , step down )
G      ( -- , go to end of word )
GD     ( n -- , go down N levels from current level,
                stop at end of this level )

Conditional Compilation [IF] [ELSE] [THEN]

PForth supports conditional compilation words similar to 'C''s #if, #else, and #endif.
[IF] ( flag -- , if true, skip to [ELSE] or [THEN] )
[ELSE] ( -- , skip to [THEN] )
[THEN] ( -- , noop, used to terminate [IF] and [ELSE] section )

 
For example: 
    TRUE constant USE_FRENCH

USE_FRENCH  [IF]
  : WELCOME  ." Bienvenue!" cr ;
[ELSE]
  : WELCOME  ." Welcome!" cr ;
[THEN]
Here is how to conditionally compile within a colon definition by using [ and ]. 
    : DOIT  ( -- )
    START.REACTOR
    IF
        [ USE_FRENCH [IF] ] ." Zut alors!"
        [ [ELSE] ] ." Uh oh!"
        [THEN]
    THEN cr
;

Miscellaneous Handy Words

.HEX ( n -- , print N as hex number )
CHOOSE ( n -- rand , select random number between 0 and N )
MAP ( -- , print dictionary information )

Local Variables { foo --}

In a complicated Forth word it is sometimes hard to keep track of where things are on the stack. If you find you are doing a lot of stack operations like DUP SWAP ROT PICK etc. then you may want to use local variables. They can greatly simplify your code. You can declare local variables for a word using a syntax similar to the stack diagram. These variables will only be accessible within that word. Thus they are "local" as opposed to "global" like regular variables. Local variables are self-fetching. They automatically put their values on the stack when you give their name. You don't need to @ the contents. Local variables do not take up space in the dictionary. They reside on the return stack where space is made for them as needed. Words written with them can be reentrant and recursive.

Consider a word that calculates the difference of two squares, Here are two ways of writing the same word. 

    : DIFF.SQUARES ( A B -- A*A-B*B ) 
    DUP * 
    SWAP DUP * 
    SWAP - 
; 
  ( or ) 
: DIFF.SQUARES { A B -- A*A-B*B } 
    A A * 
    B B * - 
; 
3 2 DIFF.SQUARES  ( would return 5 )
In the second definition of DIFF.SQUARES the curly bracket '{' told the compiler to start declaring local variables. Two locals were defined, A and B. The names could be as long as regular Forth words if desired. The "--" marked the end of the local variable list. When the word is executed, the values will automatically be pulled from the stack and placed in the local variables. When a local variable is executed it places its value on the stack instead of its address. This is called self-fetching. Since there is no address, you may wonder how you can store into a local variable. There is a special operator for local variables that does a store. It looks like -> and is pronounced "to".

Local variables need not be passed on the stack. You can declare a local variable by placing it after a "vertical bar" ( | )character. These are automatically set to zero when created. Here is a simple example that uses -> and | in a word: 

    : SHOW2*  
        { loc1 | unvar --  , 1 regular, 1 uninitialized }
        LOC1  2*  ->  UNVAR 
                (set unver to 2*LOC1 )
        UNVAR   .   ( print UNVAR )
;
3 SHOW2*   ( pass only 1 parameter, prints 6 )
Since local variable often used as counters or accumulators, we have a special operator for adding to a local variable It is +-> which is pronounced "plus to". These next two lines are functionally equivalent but the second line is faster and smaller: 
    ACCUM   10 +   -> ACCUM
10 +-> ACCUM
If you name a local variable the same as a Forth word in the dictionary, eg. INDEX or COUNT, you will be given a warning message. The local variable will still work but one could easily get confused so we warn you about this. Other errors that can occur include, missing a closing '}', missing '--', or having too many local variables.

'C' like Structures. :STRUCT

You can define 'C' like data structures in pForth using :STRUCT. For example: 
    :STRUCT  SONG
    LONG     SONG_NUMNOTES  \ define 32 bit structure member named SONG_NUMNOTES
    SHORT    SONG_SECONDS   \ define 16 bit structure member
    BYTE     SONG_QUALITY   \ define 8 bit member
    LONG     SONG_NUMBYTES  \ auto aligns after SHORT or BYTE
    RPTR     SONG_DATA      \ relocatable pointer to data
;STRUCT
    SONG  HAPPY   \ define a song structure called happy
    400  HAPPY  S!  SONG_NUMNOTES  \ set number of notes to 400
17   HAPPY  S!  SONG_SECONDS   \ S! works with all size members
    CREATE  SONG-DATA  23 , 17 , 19 , 27 ,
SONG-DATA  HAPPY S! SONG_DATA  \ store pointer in relocatable form
    HAPPY  DST  SONG    \ dump HAPPY as a SONG structure
    HAPPY   S@  SONG_NUMNOTES .  \ fetch numnotes and print
See the file "c_struct.fth" for more information.

Vectorred Execution - DEFER

Using DEFER for vectored words. In Forth and other languages you can save the address of a function in a variable. You can later fetch from that variable and execute the function it points to.This is called vectored execution. PForth provides a tool that simplifies this process. You can define a word using DEFER. This word will contain the execution token of another Forth function. When you execute the deferred word, it will execute the function it points to. By changing the contents of this deferred word, you can change what it will do. There are several words that support this process.
DEFER ( <name> -- , define a deferred word )
IS ( CFA <name> -- , set the function for a deferred word )
WHAT'S ( <name> -- CFA , return the CFA set by IS )
Simple way to see the name of what's in a deferred word:
      WHAT'S EMIT >NAME ID.
should print name of current word that's in EMIT.

 
Here is an example that uses a deferred word. 
    DEFER PRINTIT
' . IS PRINTIT   ( make PRINTIT use . )
8 3 + PRINTIT

: COUNTUP  ( -- , call deferred word )
        ." Hit RETURN to stop!" CR
        0 ( first value )
        BEGIN 1+ DUP PRINTIT CR
                ?TERMINAL
        UNTIL
;
COUNTUP  ( uses simple . )

: FANCY.PRINT  ( N -- , print in DECIMAL and HEX)
        DUP ." DECIMAL = " .
        ." , HEX = " .HEX
;
' FANCY.PRINT  IS PRINTIT  ( change printit )
WHAT'S PRINTIT >NAME ID. ( shows use of WHAT'S )
8 3 + PRINTIT
COUNTUP  ( notice that it now uses FANCY.PRINT )
Many words in the system have been defined using DEFER which means that we can change how they work without recompiling the entire system. Here is a partial list of those words 
    ABORT EMIT NUMBER?

Potential Problems with Defer

Deferred words are very handy to use, however, you must be careful with them. One problem that can occur is if you initialize a deferred system more than once. In the below example, suppose we called STUTTER twice. The first time we would save the original EMIT vector in OLD-EMIT and put in a new one. The second time we called it we would take our new function from EMIT and save it in OLD-EMIT overwriting what we had saved previously. Thus we would lose the original vector for EMIT . You can avoid this if you check to see whether you have already done the defer. Here's an example of this technique. 
    DEFER OLD-EMIT
' QUIT  IS OLD-EMIT  ( set to known value )
: EEMMIITT  ( char --- , our fun EMIT )
    DUP OLD-EMIT OLD-EMIT
; 
: STUTTER   ( --- )
    WHAT'S OLD-EMIT  'C QUIT =  ( still the same? )
    IF  ( this must be the first time )
        WHAT'S EMIT  ( get the current value of EMIT )  
        IS OLD-EMIT  ( save this value in OLD-EMIT )  
        'C EEMMIITT IS EMIT
    ELSE ."  Attempt to STUTTER twice!" CR
    THEN
; 
: STOP-IT!  ( --- )
    WHAT'S OLD-EMIT ' QUIT =
    IF  ." STUTTER not installed!" CR
    ELSE  WHAT'S OLD-EMIT IS EMIT
        'C QUIT IS OLD-EMIT  
                ( reset to show termination )
    THEN
;
In the above example, we could call STUTTER or STOP-IT! as many times as we want and still be safe.

Suppose you forget your word that EMIT now calls. As you compile new code you will overwrite the code that EMIT calls and it will crash miserably. You must reset any deferred words that call your code before you FORGET your code. The easiest way to do this is to use the word IF.FORGOTTEN to specify a cleanup word to be called if you ever FORGET the code in question. In the above example using EMIT , we could have said: 

    IF.FORGOTTEN STOP-IT!

Floating Point

PForth supports the FLOAT word set and much of the FLOATEXT word set as a compile time option.  You can select single or double precision as the default by changing the typedef of PF_FLOAT.
PForth has several options for floating point output.
FS. ( r -f- , prints in scientific/exponential format )
FE. ( r -f- , prints in engineering format, exponent if multiple of 3  )
FG. ( r -f- , prints in normal or exponential format depending on size )
F. ( r -f- , as defined by the standard )
Here is an example of output from each word for a number ranging from large to very small.
     FS.             FE.            FG.           F.
1.234000e+12     1.234000e+12     1.234e+12     1234000000000. 
1.234000e+11     123.4000e+09     1.234e+11     123400000000. 
1.234000e+10     12.34000e+09     1.234e+10     12340000000. 
1.234000e+09     1.234000e+09     1.234e+09     1234000000. 
1.234000e+08     123.4000e+06     1.234e+08     123400000. 
1.234000e+07     12.34000e+06     1.234e+07     12340000. 
1.234000e+06     1.234000e+06     1234000.     1234000. 
1.234000e+05     123.4000e+03     123400.     123400.0 
1.234000e+04     12.34000e+03     12340.     12340.00 
1.234000e+03     1.234000e+03     1234.     1234.000 
1.234000e+02     123.4000e+00     123.4     123.4000 
1.234000e+01     12.34000e+00     12.34     12.34000 
1.234000e+00     1.234000e+00     1.234     1.234000 
1.234000e-01     123.4000e-03     0.1234     0.1234000 
1.234000e-02     12.34000e-03     0.01234     0.0123400 
1.234000e-03     1.234000e-03     0.001234     0.0012340 
1.234000e-04     123.4000e-06     0.0001234     0.0001234 
1.234000e-05     12.34000e-06     1.234e-05     0.0000123 
1.234000e-06     1.234000e-06     1.234e-06     0.0000012 
1.234000e-07     123.4000e-09     1.234e-07     0.0000001 
1.234000e-08     12.34000e-09     1.234e-08     0.0000000 
1.234000e-09     1.234000e-09     1.234e-09     0.0000000 
1.234000e-10     123.4000e-12     1.234e-10     0.0000000 
1.234000e-11     12.34000e-12     1.234e-11     0.0000000

1.234568e+12     1.234568e+12     1.234568e+12     1234567890000. 
1.234568e+11     123.4568e+09     1.234568e+11     123456789000. 
1.234568e+10     12.34568e+09     1.234568e+10     12345678900. 
1.234568e+09     1.234568e+09     1.234568e+09     1234567890. 
1.234568e+08     123.4568e+06     1.234568e+08     123456789. 
1.234568e+07     12.34568e+06     1.234568e+07     12345679. 
1.234568e+06     1.234568e+06     1234568.     1234568. 
1.234568e+05     123.4568e+03     123456.8     123456.8 
1.234568e+04     12.34568e+03     12345.68     12345.68 
1.234568e+03     1.234568e+03     1234.568     1234.568 
1.234568e+02     123.4568e+00     123.4568     123.4568 
1.234568e+01     12.34568e+00     12.34568     12.34568 
1.234568e+00     1.234568e+00     1.234568     1.234568 
1.234568e-01     123.4568e-03     0.1234568     0.1234568 
1.234568e-02     12.34568e-03     0.01234568     0.0123456 
1.234568e-03     1.234568e-03     0.001234568     0.0012345 
1.234568e-04     123.4568e-06     0.0001234568     0.0001234 
1.234568e-05     12.34568e-06     1.234568e-05     0.0000123 
1.234568e-06     1.234568e-06     1.234568e-06     0.0000012 
1.234568e-07     123.4568e-09     1.234568e-07     0.0000001 
1.234568e-08     12.34568e-09     1.234568e-08     0.0000000 
1.234568e-09     1.234568e-09     1.234568e-09     0.0000000 
1.234568e-10     123.4568e-12     1.234568e-10     0.0000000 
1.234568e-11     12.34568e-12     1.234568e-11     0.0000000

pForth Design

'C' kernel

The pForth kernel is written in 'C' for portability. The inner interpreter is implemented in the function ExecuteToken() which is in pf_inner.c. 
    void pfExecuteToken( ExecToken XT );
It is passed an execution token the same as EXECUTE would accept. It handles threading of secondaries and also has a large switch() case statement to interpret primitives. It is in one huge routine to take advantage of register variables, and to reduce calling overhead. Hopefully, your compiler will optimise the switch() statement into a jump table so it will run fast.

Dictionary Structures

This Forth supports multiple dictionaries. Each dictionary consists of a header segment and a seperate code segment. The header segment contains link fields and names. The code segment contains tokens and data. The headers, as well as some entire dictionaries such as the compiler support words, can be discarded when creating a stand-alone app.

[NOT IMPLEMENTED] Dictionaries can be split so that the compile time words can be placed above the main dictionary. Thus they can use the same relative addressing but be discarded when turnkeying.

Execution tokens are either an index of a primitive ( n < NUM_PRIMITIVES), or the offset of a secondary in the code segment. ( n >= NUM_PRIMITIVES )

The NAME HEADER portion of the dictionary contains a structure for each named word in the dictionary. It contains the following fields: 

    bytes 4 Link Field relative address of previous name header
4 Code Pointer relative address of corresponding code
n Name Field name as counted string Headers are quad byte aligned.
The CODE portion of the dictionary consists of the following structures:

Primitive

No Forth code. 'C' code in "pf_inner.c".

Secondary

    4*n Parameter Field execution tokens
4 ID_NEXT = 0 terminates secondary

CREATE DOES>

    4 ID_CREATE_P token
4 Token for optional DOES> code, OR ID_NEXT = 0
4 ID_NEXT = 0
n Body = arbitrary data

Deferred Word

    4 ID_DEFER_P same action as ID_NOOP, identifies deferred words
4 Execution Token of word to execute.
4 ID_NEXT = 0

Call to custom 'C' function.

    4 ID_CALL_C
4 Pack C Call Info Bits
      0-15 = Function Index Bits
16-23 = FunctionTable Index (Unused) Bits
24-30 = NumParams Bit
31 = 1 if function returns value
    4 ID_NEXT = 0

Custom Compilation of pForth

Compiler Options

There are several versions of PForth that can be built. By default, the full kernel will be built. For custom builds, define the following options in the Makefile before compiling the 'C' code:

PF_NO_INIT

    Don't compile the code used to initially build the dictionary. This can be used to save space if you already have a prebuilt dictionary.
PF_NO_SHELL
    Don't compile the outer interpreter and Forth compiler. This can be used with Cloned dictionaries.
PF_NO_MALLOC
    Replace malloc() and free() function with pForth's own version. See pf_mem.c for more details.
PF_USER_MALLOC='"filename.h"'
    Replace malloc() and free() function with users custom version. See pf_mem.h for details.
PF_MEM_POOL_SIZE=numbytes
    Size of array in bytes used by pForth custom allocator.
PF_NO_GLOBAL_INIT
    Define this if you want pForth to not rely on initialization of global variables by the loader. This may be required for some embedded systems that may not have a fully functioning loader.  Take a look in "pfcustom.c" for an example of its use.
PF_USER_INC1='"filename.h"'
    File to include BEFORE other include files. Generally set to host dependent files such as "pf_mac.h".
PF_USER_INC2='"filename.h"'
    File to include AFTER other include files. Generally used to #undef and re#define symbols. See "pf_win32.h" for an example.
PF_NO_CLIB
    Replace 'C' lib calls like toupper and memcpy with pForth's own version. This is useful for embedded systems.
PF_USER_CLIB='"filename.h"'
    Rreplace 'C' lib calls like toupper and memcpy with users custom version. See pf_clib.h for details.
PF_NO_FILEIO
    System does not support standard file I/O so stub it out. Setting this flag will automatically set PF_STATIC_DIC.
PF_USER_CHARIO='"filename.h"'
    Replace stdio terminal calls like getchar() and putchar() with users custom version. See pf_io.h for details.
PF_USER_FILEIO='"filename.h"'
    Replace stdio file calls like fopen and fread with users custom version. See pf_io.h for details.
PF_USER_FLOAT='"filename.h"'
    Replace floating point math calls like sin and pow with users custom version. Also defines PF_FLOAT.
PF_USER_INIT=MyInit()
    Call a user defined initialization function that returns a negative error code if it fails.
PF_USER_TERM=MyTerm()
    Call a user defined void termination function.
PF_STATIC_DIC
    Compile in static dictionary instead of loading dictionary. from file. Use "utils/savedicd.fth" to save a dictionary as 'C' source code in a file called "pfdicdat.h".
PF_SUPPORT_FP
    Compile ANSI floating point support.

Building pForth on Supported Hosts

To build on UNIX, do nothing, system will default to "pf_unix.h".

To build on Macintosh: 

    -DPF_USER_INC1='"pf_mac.h"'
To build on PCs: 
    -DPF_USER_INC2='"pf_win32.h"'
To build a system that only runs turnkey or cloned binaries: 
    -DPF_NO_INIT -DPF_NO_SHELL

Compiling for Embedded Systems

You may want to create a version of pForth that can be run on a small system that does not support file I/O. This is useful when bringing up new computer systems. On UNIX systems, you can use the supplied gmake target. Simply enter: 
    gmake pfemb
For other systems, here are the steps to create an embedded pForth.
  1. Determine whether your target system has a different endian-ness than your host system.  If the address of a long word is the address of the most significant byte, then it is "big endian". Examples of big endian processors are Sparc, Motorola 680x0 and PowerPC60x.  If the address of a long word is the address of the lest significant byte, then it is "Little Endian". Examples of little endian processors are Intel 8088 and derivatives such as the Intel Pentium.
  2. If your target system has a different endian-ness than your host system, then you must compile a version of pForth for your host that matches the target.  Rebuild pForth with either PF_BIG_ENDIAN_DIC or PF_LITTLE_ENDIAN_DIC defined.  You will need to rebuild pforth.dic as well as the executable Forth.  If you do not specify one of these variables, then the dictionary will match the native endian-ness of the processor (and run faster as a result).
  3. Execute pForth. Notice the message regarding the endian-ness of the dictionary.
  4. Compile your custom Forth words on the host development system.
  5. Compile the pForth utulity "utils/savedicd.fth".
  6. Enter in pForth: SDAD
  7. SDAD will generate a file called "pfdicdat.h" that contains your dictionary in source code form.
  8. Rewrite the character primitives sdTerminalOut(), sdTerminalIn() and sdTerminalFlush() defined in pf_io.h to use your new computers communications port.
  9. Write a "user_chario.h" file based on the API defined in "pf_io.h".
  10. Compile a new version of pForth for your target machine with the following options:
      11. -DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \
-DPF_USER_CHARIO="user_chario.h" \
-DPF_NO_CLIB -DPF_STATIC_DIC
  11. The file "pfdicdat.h" will be compiled into this executable and your dictionary will thus be included in the pForth executable as a static array.
  12. Burn a ROM with your new pForth and run it on your target machine.
  13. If you compiled a version of pForth with different endian-ness than your host system, do not use it for daily operation because it will be much slower than a native version.

Linking with Custom 'C' Functions

You can call the pForth interpreter as an embedded tool in a 'C' application. For an example of this, see the file pf_main.c. This application does nothing but load the dictionary and call the pForth interpreter.

You can call 'C' from pForth by adding your own custom 'C' functions to a dispatch table, and then adding Forth words to the dictionary that call those functions. See the file "pfcustom.c" for more information.

Testing your Compiled pForth

Once you have compiled pForth, you can test it using the small verification suite we provide.  The first test you should run was written by John Hayes at John Hopkins University.  Enter: 
    pforth
include tester.fth
include coretest.fth
bye
The output will be self explanatory.  There are also a number of tests that I have added that print the number of successes and failures. Enter: 
    pforth t_corex.fth
pforth t_locals.fth
pforth t_strings.fth
pforth t_floats.ft
Note that t_corex.fth reveals an expected error because SAVE-INPUT is not fully implemented. (FIXME)

PForth source code is freely available.  The author is available for customization of pForth, porting to new platforms, or developing pForth applications on a contractual basis.  If interested, contact  Phil Burk at philburk@softsynth.com

Back to pForth Home Page pforth-21/docs/pf_tut.htm100664 1750 1750 141162 6557124776 14256 0ustar bdalebdale pForth Tutorial

Forth Tutorial

by Phil Burk

To pForth Home Page

Table of Contents

The intent of this tutorial is to provide a series of experiments that will introduce you to the major concepts of Forth. It is only a starting point. Feel free to deviate from the sequences I provide. A free form investigation that is based on your curiosity is probably the best way to learn any language. Forth is especially well adapted to this type of learning.

This tutorial is written for the PForth implementation of the ANS Forth standard. I have tried to restrict this tutorial to words that are part of the ANS standard but some PForth specific words may have crept in.

In the tutorials, I will print the things you need to type in upper case, and indent them. You can enter them in upper or lower case. At the end of each line, press the RETURN (or ENTER) key; this causes Forth to interpret what you've entered.

Forth Syntax

Forth has one of the simplest syntaxes of any computer language. The syntax can be stated as follows, "Forth code is a bunch of words with spaces between them." This is even simpler than English! Each word is equivalent to a function or subroutine in a language like 'C'. They are executed in the order they appear in the code. The following statement, for example, could appear in a Forth program: 
     WAKE.UP EAT.BREAKFAST WORK EAT.DINNER PLAY SLEEP
Notice that WAKE.UP has a dot between the WAKE and UP. The dot has no particular meaning to the Forth compiler. I simply used a dot to connect the two words together to make one word. Forth word names can have any combination of letters, numbers, or punctuation. We will encounter words with names like: 
     ." #S SWAP ! @ ACCEPT . *
They are all called words. The word $%%-GL7OP is a legal Forth name, although not a very good one. It is up to the programmer to name words in a sensible manner.

Now it is time to run your Forth and begin experimenting. Please consult the manual for your Forth for instructions on how to run it.

Stack Manipulation

The Forth language is based on the concept of a stack. Imagine a stack of blocks with numbers on them. You can add or remove numbers from the top of the stack. You can also rearrange the order of the numbers. Forth uses several stacks. The DataStack is the one used for passing data between Forth words so we will concentrate our attention there. The Return Stack is another Forth stack that is primarily for internal system use. In this tutorial, when we refer to the "stack," we will be referring to the Data Stack.

The stack is initially empty. To put some numbers on the stack, enter: 

    23 7 9182
Let's now print the number on top of the stack using the Forth word ' . ', which is pronounced " dot ". This is a hard word to write about in a manual because it is a single period.

Enter: . 

You should see the last number you entered, 9182 , printed. Forth has a very handy word for showing you what's on the stack. It is .S , which is pronounced "dot S". The name was constructed from "dot" for print, and "S" for stack. (PForth will automatically print the stack after every line if the TRACE-STACK variable is set to TRUE.) If you enter: 

    .S
you will see your numbers in a list. The number at the far right is the one on top of the stack.

You will notice that the 9182 is not on the stack. The word ' . ' removes the number on top of the stack before printing it. In contrast, ' .S ' leaves the stack untouched.

We have a way of documenting the effect of words on the stack with a stack diagram. A stack diagram is contained in parentheses. In Forth, the parentheses indicate a comment. In the examples that follow, you do not need to type in the comments. When you are programming, of course, we encourage the use of comments and stack diagrams to make your code more readable. In this manual, we often indicate stack diagrams in bold text like the one that follows. Do not type these in. The stack diagram for a word like ' . ' would be: 

. ( N -- , print number on top of stack )
The symbols to the left of -- describe the parameters that a word expects to process. In this example, N stands for any integer number. To the right of --, up to the comma, is a description of the stack parameters when the word is finished, in this case there are none because 'dot' "eats" the N that was passed in. (Note that the stack descriptions are not necessary, but they are a great help when learning other peoples programs.)

The text following the comma is an English description of the word. You will note that after the -- , N is gone. You may be concerned about the fact that there were other numbers on the stack, namely 23 and 7 . The stack diagram, however, only describes the portion of the stack that is affected by the word. For a more detailed description of the stack diagrams, there is a special section on them in this manual right before the main glossary section.

Between examples, you will probably want to clear the stack. If you enter 0SP, pronounced "zero S P", then the stack will be cleared.

Since the stack is central to Forth, it is important to be able to alter the stack easily. Let's look at some more words that manipulate the stack. Enter: 

    0SP .S \ That's a 'zero' 0, not an 'oh' O.
777 DUP .S
You will notice that there are two copies of 777 on the stack. The word DUP duplicates the top item on the stack. This is useful when you want to use the number on top of the stack and still have a copy. The stack diagram for DUP would be: 
DUP ( n -- n n , DUPlicate top of stack )
Another useful word, is SWAP. Enter: 
    0SP 
23 7 .S 
SWAP .S 
SWAP .S
The stack diagram for SWAP would be: 
SWAP ( a b -- b a , swap top two items on stack )
Now enter: 
    OVER .S
OVER .S
The word OVER causes a copy of the second item on the stack to leapfrog over the first. It's stack diagram would be:

OVER ( a b -- a b a , copy second item on stack )

Here is another commonly used Forth word:

DROP ( a -- , remove item from the stack )

Can you guess what we will see if we enter: 

    0SP 11 22 .S
DROP .S
Another handy word for manipulating the stack is ROT. Enter: 
    0SP
11 22 33 44 .S
ROT .S
The stack diagram for ROT is, therefore:

ROT ( a b c -- b c a , ROTate third item to top ) 

You have now learned the more important stack manipulation words. You will see these in almost every Forth program. I should caution you that if you see too many stack manipulation words being used in your code then you may want to reexamine and perhaps reorganize your code. You will often find that you can avoid excessive stack manipulations by using local or global VARIABLES which will be discussed later.

If you want to grab any arbitrary item on the stack, use PICK . Try entering: 

    0SP
14 13 12 11 10
3 PICK . ( prints 13 )
0 PICK . ( prints 10 )
4 PICK .
PICK makes a copy of the Nth item on the stack. The numbering starts with zero, therefore:
    0 PICK is equivalent to DUP
    1 PICK is equivalent to OVER 
PICK ( ... v3 v2 v1 v0 N -- ... v3 v2 v1 v0 vN ) 

(Warning. The Forth-79 and FIG Forth standards differ from the ANS and Forth '83 standard in that their PICK numbering starts with one, not zero.)

I have included the stack diagrams for some other useful stack manipulation words. Try experimenting with them by putting numbers on the stack and calling them to get a feel for what they do. Again, the text in parentheses is just a comment and need not be entered.

DROP ( n -- , remove top of stack ) 

?DUP ( n -- n n | 0 , duplicate only if non-zero, '|' means OR ) 

-ROT ( a b c -- c a b , rotate top to third position ) 

2SWAP ( a b c d -- c d a b , swap pairs ) 

2OVER ( a b c d -- a b c d a b , leapfrog pair ) 

2DUP ( a b -- a b a b , duplicate pair ) 

2DROP ( a b -- , remove pair ) 

NIP ( a b -- b , remove second item from stack ) 

TUCK ( a b -- b a b , copy top item to third position ) 

Problems:

Start each problem by entering: 
    0SP 11 22 33
Then use the stack manipulation words you have learned to end up with the following numbers on the stack: 
    1) 11 33 22 22
    2) 22 33
    3) 22 33 11 11 22
    4) 11 33 22 33 11
    5) 33 11 22 11 22
Answers to the problems can be found at the end of this tutorial.

Arithmetic

Great joy can be derived from simply moving numbers around on a stack. Eventually, however, you'll want to do something useful with them. This section describes how to perform arithmetic operations in Forth.

The Forth arithmetic operators work on the numbers currently on top of the stack. If you want to add the top two numbers together, use the Forth word + , pronounced "plus". Enter: 

    2 3 + .
2 3 + 10 + .
This style of expressing arithmetic operations is called Reverse Polish Notation, or RPN. It will already be familiar to those of you with HP calculators. In the following examples, I have put the algebraic equivalent representation in a comment.

Some other arithmetic operators are - * / . Enter: 

    30 5 - . ( 25=30-5 )
30 5 / . ( 6=30/5 )
30 5 * . ( 150=30*5 )
30 5 + 7 / . \ 5=(30+5)/7
Some combinations of operations are very common and have been coded in assembly language for speed. For example, 2* is short for 2 * . You should use these whenever possible to increase the speed of your program. These include: 
    1+ 1- 2+ 2- 2* 2/
Try entering: 
    10 1- .
7 2* 1+ . ( 15=7*2+1 )
One thing that you should be aware of is that when you are doing division with integers using / , the remainder is lost. Enter: 
    15 5 / .
17 5 / .
This is true in all languages on all computers. Later we will examine /MOD and MOD which do give the remainder.

Defining a New Word

It's now time to write a small program in Forth. You can do this by defining a new word that is a combination of words we have already learned. Let's define and test a new word that takes the average of two numbers.
We will make use of two new words, : ( "colon"), and ; ( "semicolon") . These words start and end a typical Forth definition. Enter:
    : AVERAGE ( a b -- avg ) + 2/ ;
Congratulations. You have just written a Forth program. Let's look more closely at what just happened. The colon told Forth to add a new word to its list of words. This list is called the Forth dictionary. The name of the new word will be whatever name follows the colon. Any Forth words entered after the name will be compiled into the new word. This continues until the semicolon is reached which finishes the definition.

Let's test this word by entering: 

    10 20 AVERAGE . ( should print 15 )
Once a word has been defined, it can be used to define more words. Let's write a word that tests our word.. Enter: 
    : TEST ( --) 50 60 AVERAGE . ;
TEST
Try combining some of the words you have learned into new Forth definitions of your choice. If you promise not to be overwhelmed, you can get a list of the words that are available for programming by entering: 
    WORDS
Don't worry, only a small fraction of these will be used directly in your programs.

More Arithmetic

When you need to know the remainder of a divide operation. /MOD will return the remainder as well as the quotient. the word MOD will only return the remainder. Enter: 
    0SP
53 10 /MOD .S
0SP
7 5 MOD .S
Two other handy words are MIN and MAX . They accept two numbers and return the MINimum or MAXimum value respectively. Try entering the following: 
    56 34 MAX .
56 34 MIN .
-17 0 MIN .
Some other useful words are:

ABS ( n -- abs(n) , absolute value of n ) 

NEGATE ( n -- -n , negate value, faster then -1 * ) 

LSHIFT ( n c -- n<<c , left shift of n ) 

RSHIFT ( n c -- n>>c , logical right shift of n ) 

ARSHIFT ( n c -- n>>c ) , arithmetic right shift of n ) 

ARSHIFT or LSHIFT can be used if you have to multiply quickly by a power of 2 . A right shift is like doing a divide by 2. This is often faster than doing a regular multiply or divide. Try entering: 

    : 256* 8 LSHIFT ;
3 256* .

Arithmetic Overflow

If you are having problems with your calculation overflowing the 32-bit precision of the stack, then you can use */ . This produces an intermediate result that is 64 bits long. Try the following three methods of doing the same calculation. Only the one using */ will yield the correct answer, 5197799. 
    34867312 99154 * 665134 / .
34867312 665134 / 99154 * .
34867312 99154 665134 */ .

Convert Algebraic Expressions to Forth

How do we express complex algebraic expressions in Forth? For example: 20 + (3 * 4)

To convert this to Forth you must order the operations in the order of evaluation. In Forth, therefore, this would look like: 

    3 4 * 20 +
Evaluation proceeds from left to right in Forth so there is no ambiguity. Compare the following algebraic expressions and their Forth equivalents: (Do not enter these!) 
    (100+50)/2 ==> 100 50 + 2/
((2*7) + (13*5)) ==> 2 7 * 13 5 * +
If any of these expressions puzzle you, try entering them one word at a time, while viewing the stack with .S .

Problems:

Convert the following algebraic expressions to their equivalent Forth expressions. (Do not enter these because they are not Forth code!) 
    (12 * ( 20 - 17 ))
    (1 - ( 4 * (-18) / 6) )
    ( 6 * 13 ) - ( 4 * 2 * 7 )
Use the words you have learned to write these new words: 
    SQUARE ( N -- N*N , calculate square )
    DIFF.SQUARES ( A B -- A*A-B*B , difference of squares )
    AVERAGE4 ( A B C D -- [A+B+C+D]/4 )
    HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS , convert )
Answers to the problems can be found at the end of this tutorial.

Character Input and Output

The numbers on top of the stack can represent anything. The top number might be how many blue whales are left on Earth or your weight in kilograms. It can also be an ASCII character. Try entering the following: 
    72 EMIT 105 EMIT
You should see the word "Hi" appear before the OK. The 72 is an ASCII 'H' and 105 is an 'i'. EMIT takes the number on the stack and outputs it as a character. If you want to find the ASCII value for any character, you can use the word ASCII . Enter: 
    CHAR W .
CHAR % DUP . EMIT
CHAR A DUP .
32 + EMIT
There is an ASCII chart in the back of this manual for a complete character list.

Notice that the word CHAR is a bit unusual because its input comes not from the stack, but from the following text. In a stack diagram, we represent that by putting the input in angle brackets, <input>. Here is the stack diagram for CHAR.

CHAR ( <char> -- char , get ASCII value of a character ) 

Using EMIT to output character strings would be very tedious. Luckily there is a better way. Enter: 

    : TOFU ." Yummy bean curd!" ;
TOFU
The word ." , pronounced "dot quote", will take everything up to the next quotation mark and print it to the screen. Make sure you leave a space after the first quotation mark. When you want to have text begin on a new line, you can issue a carriage return using the word CR . Enter: 
    : SPROUTS ." Miniature vegetables." ;
: MENU
    CR TOFU CR SPROUTS CR
;
MENU
You can emit a blank space with SPACE . A number of spaces can be output with SPACES . Enter: 
    CR TOFU SPROUTS
CR TOFU SPACE SPROUTS
CR 10 SPACES TOFU CR 20 SPACES SPROUTS
For character input, Forth uses the word KEY which corresponds to the word EMIT for output. KEY waits for the user to press a key then leaves its value on the stack. Try the following. 
    : TESTKEY ( -- )
    ." Hit a key: " KEY CR
    ." That = " . CR
;
TESTKEY
[Note: On some computers, the input if buffered so you will need to hit the ENTER key after typing your character.]

EMIT ( char -- , output character ) 

KEY ( -- char , input character ) 

SPACE ( -- , output a space ) 

SPACES ( n -- , output n spaces ) 

CHAR ( <char> -- char , convert to ASCII ) 

CR ( -- , start new line , carriage return ) 

." ( -- , output " delimited text ) 



Compiling from Files

PForth can read read from ordinary text files so you can use any editor that you wish to write your programs.

Sample Program

Enter into your file, the following code. 
    \ Sample Forth Code
\ Author: your name
    : SQUARE ( n -- n*n , square number )
    DUP *
;
    : TEST.SQUARE ( -- )
    CR ." 7 squared = "
    7 SQUARE . CR
;
Now save the file to disk.

The text following the \ character is treated as a comment. This would be a REM statement in BASIC or a /*---*/ in 'C'. The text in parentheses is also a comment.

Using INCLUDE

"INCLUDE" in Forth means to compile from a file.

You can compile this file using the INCLUDE command. If you saved your file as WORK:SAMPLE, then compile it by entering: 

    INCLUDE SAMPLE.FTH
Forth will compile your file and tell you how many bytes it has added to the dictionary. To test your word, enter: 
    TEST.SQUARE
Your two words, SQUARE and TEST.SQUARE are now in the Forth dictionary. We can now do something that is very unusual in a programming language. We can "uncompile" the code by telling Forth to FORGET it. Enter: 
    FORGET SQUARE
This removes SQUARE and everything that follows it, ie. TEST.SQUARE, from the dictionary. If you now try to execute TEST.SQUARE it won't be found.

Now let's make some changes to our file and reload it. Go back into the editor and make the following changes: (1) Change TEST.SQUARE to use 15 instead of 7 then (2) Add this line right before the definition of SQUARE: 

    ANEW TASK-SAMPLE.FTH
Now Save your changes and go back to the Forth window.

You're probably wondering what the line starting with ANEW was for. ANEW is always used at the beginning of a file. It defines a special marker word in the dictionary before the code. The word typically has "TASK-" as a prefix followed by the name of the file. When you ReInclude a file, ANEW will automatically FORGET the old code starting after the ANEW statement. This allows you to Include a file over and over again without having to manually FORGET the first word. If the code was not forgotten, the dictionary would eventually fill up.

If you have a big project that needs lots of files, you can have a file that will load all the files you need. Sometimes you need some code to be loaded that may already be loaded. The word INCLUDE? will only load code if it isn't already in the dictionary. In this next example, I assume the file is on the volume WORK: and called SAMPLE. If not, please substitute the actual name. Enter: 

    FORGET TASK-SAMPLE.FTH
INCLUDE? SQUARE WORK:SAMPLE
INCLUDE? SQUARE WORK:SAMPLE
Only the first INCLUDE? will result in the file being loaded.

Variables

Forth does not rely as heavily on the use of variables as other compiled languages. This is because values normally reside on the stack. There are situations, of course, where variables are required. To create a variable, use the word VARIABLE as follows: 
    VARIABLE MY-VAR
This created a variable named MY-VAR . A space in memory is now reserved to hold its 32-bit value. The word VARIABLE is what's known as a "defining word" since it creates new words in the dictionary. Now enter: 
    MY-VAR .
The number you see is the address, or location, of the memory that was reserved for MY-VAR. To store data into memory you use the word ! , pronounced "store". It looks like an exclamation point, but to a Forth programmer it is the way to write 32-bit data to memory. To read the value contained in memory at a given address, use the Forth word @ , pronounced "fetch". Try entering the following: 
    513 MY-VAR !
MY-VAR @ .
This sets the variable MY-VAR to 513 , then reads the value back and prints it. The stack diagrams for these words follows:

@ ( address -- value , FETCH value FROM address in memory ) 

! ( value address -- , STORE value TO address in memory )

VARIABLE ( <name> -- , define a 4 byte memory storage location)

A handy word for checking the value of a variable is ? , pronounced "question". Try entering: 

    MY-VAR ?
If ? wasn't defined, we could define it as: 
    : ? ( address -- , look at variable )
    @ .
;
Imagine you are writing a game and you want to keep track of the highest score. You could keep the highest score in a variable. When you reported a new score, you could check it aginst the highest score. Try entering this code in a file as described in the previous section: 
    VARIABLE HIGH-SCORE
    : REPORT.SCORE ( score -- , print out score )
    DUP CR ." Your Score = " . CR
    HIGH-SCORE @ MAX ( calculate new high )
    DUP ." Highest Score = " . CR
    HIGH-SCORE ! ( update variable )
;
Save the file to disk, then compile this code using the INCLUDE word. Test your word as follows: 
    123 REPORT.SCORE
9845 REPORT.SCORE
534 REPORT.SCORE
The Forth words @ and ! work on 32-bit quantities. Some Forths are "16-bit" Forths. They fetch and store 16-bit quantities. Forth has some words that will work on 8 and 16-bit values. C@ and C! work characters which are usually for 8-bit bytes. The 'C' stands for "Character" since ASCII characters are 8-bit numbers. Use W@ and W! for 16-bit "Words."

Another useful word is +! , pronounced "plus store." It adds a value to a 32-bit value in memory. Try: 

    20 MY-VAR !
5 MY-VAR +!
MY-VAR @ .
Forth also provides some other words that are similar to VARIABLE. Look in the glossary for VALUE and ARRAY. Also look at the section on "local variables" which are variables which only exist on the stack while a Forth word is executing.

A word of warning about fetching and storing to memory: You have now learned enough about Forth to be dangerous. The operation of a computer is based on having the right numbers in the right place in memory. You now know how to write new numbers to any place in memory. Since an address is just a number, you could, but shouldn't, enter: 

    73 253000 ! ( Do NOT do this. )
The 253000 would be treated as an address and you would set that memory location to 73. I have no idea what will happen after that, maybe nothing. This would be like firing a rifle through the walls of your apartment building. You don't know who or what you are going to hit. Since you share memory with other programs including the operating system, you could easily cause the computer to behave strangely, even crash. Don't let this bother you too much, however. Crashing a computer, unlike crashing a car, does not hurt the computer. You just have to reboot. The worst that could happen is that if you crash while the computer is writing to a disk, you could lose a file. That's why we make backups. This same potential problem exists in any powerful language, not just Forth. This might be less likely in BASIC, however, because BASIC protects you from a lot of things, including the danger of writing powerful programs.

Another way to get into trouble is to do what's called an "odd address memory access." The 68000 processor arranges words and longwords, 16 and 32 bit numbers, on even addresses. If you do a @ or ! , or W@ or W! , to an odd address, the 68000 processor will take exception to this and try to abort.

Forth gives you some protection from this by trapping this exception and returning you to the OK prompt. If you really need to access data on an odd address, check out the words ODD@ and ODD! in the glossary. C@ and C! work fine on both odd and even addresses.

Constants

If you have a number that is appearing often in your program, we recommend that you define it as a "constant." Enter: 
    128 CONSTANT MAX_CHARS
MAX_CHARS .
We just defined a word called MAX_CHARS that returns the value on the stack when it was defined. It cannot be changed unless you edit the program and recompile. Using CONSTANT can improve the readability of your programs and reduce some bugs. Imagine if you refer to the number 128 very often in your program, say 8 times. Then you decide to change this number to 256. If you globally change 128 to 256 you might change something you didn't intend to. If you change it by hand you might miss one, especially if your program occupies more than one file. Using CONSTANT will make it easy to change. The code that results is equally as fast and small as putting the numbers in directly. I recommend defining a constant for almost any number.

Logical Operators

These next two sections are concerned with decision making. This first section deals with answering questions like "Is this value too large?" or "Does the guess match the answer?". The answers to questions like these are either TRUE or FALSE. Forth uses a 0 to represent FALSE and a -1 to represent TRUE. TRUE and FALSE have been capitalized because they have been defined as Forth constants. Try entering: 
    23 71 = .
18 18 = .
You will notice that the first line printed a 0, or FALSE, and the second line a -1, or TRUE. The equal sign in Forth is used as a question, not a statement. It asks whether the top two items on the stack are equal. It does not set them equal. There are other questions that you can ask. Enter: 
    23 198 < .
23 198 > .
254 15 > .
In California, the drinking age for alcohol is 21. You could write a simple word now to help bartenders. Enter: 
    : DRINK? ( age -- flag , can this person drink? )
    20 >
;
    20 DRINK? .
21 DRINK? .
43 DRINK? .
The word FLAG in the stack diagram above refers to a logical value.

Forth provides special words for comparing a number to 0. They are 0= 0> and 0< . Using 0> is faster than calling 0 and > separately. Enter:

    23 0> . ( print -1 )
    -23 0> . ( print 0 )
    23 0= . ( print 0 )
For more complex decisions, you can use the Boolean operators OR , AND , and NOT . OR returns a TRUE if either one or both of the top two stack items are true. 
    TRUE TRUE OR .
TRUE FALSE OR .
FALSE FALSE OR .
AND only returns a TRUE if both of them are true. 
    TRUE TRUE AND .
TRUE FALSE AND .
NOT reverses the value of the flag on the stack. Enter: 
    TRUE .
TRUE NOT .
Logical operators can be combined. 
    56 3 > 56 123 < AND .
23 45 = 23 23 = OR .
Here are stack diagrams for some of these words. See the glossary for a more complete list.

< ( a b -- flag , flag is true if A is less than B )

> ( a b -- flag , flag is true if A is greater than B )

= ( a b -- flag , flag is true if A is equal to B )

0= ( a -- flag , true if a equals zero )

OR ( a b -- a||b , perform logical OR of bits in A and B )

AND ( a b -- a&b , perform logical AND of bits in A and B )

NOT ( flag -- opposite-flag , true if false, false if true )

Problems:

1) Write a word called LOWERCASE? that returns TRUE if the number on top of the stack is an ASCII lowercase character. An ASCII 'a' is 97 . An ASCII 'z' is 122 . Test using the characters " A ` a q z { ". 
    CHAR A LOWERCASE? . ( should print 0 )
CHAR a LOWERCASE? . ( should print -1 )
Answers to the problems can be found at the end of this tutorial.

Conditionals - IF ELSE THEN CASE

You will now use the TRUE and FALSE flags you learned to generate in the last section. The "flow of control" words accept flags from the stack, and then possibly "branch" depending on the value. Enter the following code. 
    : .L ( flag -- , print logical value )
    IF ." True value on stack!"
    ELSE ." False value on stack!"
    THEN
;
    0 .L
FALSE .L
TRUE .L
23 7 < .L
You can see that when a TRUE was on the stack, the first part got executed. If a FALSE was on the stack, then the first part was skipped, and the second part was executed. One thing you will find interesting is that if you enter: 
    23 .L
the value on the stack will be treated as true. The flow of control words consider any value that does not equal zero to be TRUE.

The ELSE word is optional in the IF...THEN construct. Try the following: 

    : BIGBUCKS? ( ammount -- )
    1000 >
    IF ." That's TOO expensive!"
    THEN
;
    531 BIGBUCKS?
1021 BIGBUCKS?
Many Forths also support a CASE statement similar to switch() in 'C'. Enter: 
    : TESTCASE ( N -- , respond appropriately )
    CASE
        0 OF ." Just a zero!" ENDOF
        1 OF ." All is ONE!" ENDOF
        2 OF WORDS ENDOF
        DUP . ." Invalid Input!"
    ENDCASE CR
;
    0 TESTCASE
1 TESTCASE
5 TESTCASE
See CASE in the glossary for more information.

Problems:

1) Write a word called DEDUCT that subtracts a value from a variable containing your checking account balance. Assume the balance is in dollars. Print the balance. Print a warning if the balance is negative. 
    VARIABLE ACCOUNT
    : DEDUCT ( n -- , subtract N from balance )
    ????????????????????????????????? ( you fill this in )
;
    300 ACCOUNT ! ( initial funds )
40 DEDUCT ( prints 260 )
200 DEDUCT ( print 60 )
100 DEDUCT ( print -40 and give warning! )
Answers to the problems can be found at the end of this tutorial.

Loops

Another useful pair of words is BEGIN...UNTIL . These are used to loop until a given condition is true. Try this: 
    : COUNTDOWN  ( N -- )
    BEGIN
        DUP . CR       ( print number on top of stack )
        1-  DUP  0<    ( loop until we go negative )
    UNTIL
;
    16 COUNTDOWN
This word will count down from N to zero.

If you know how many times you want a loop to execute, you can use the DO...LOOP construct. Enter: 

    : SPELL
    ." ba"
    4 0 DO
        ." na"
    LOOP
;
This will print "ba" followed by four occurrences of "na". The ending value is placed on the stack before the beginning value. Be careful that you don't pass the values in reverse. Forth will go "the long way around" which could take awhile. The reason for this order is to make it easier to pass the loop count into a word on the stack. Consider the following word for doing character graphics. Enter: 
    : PLOT# ( n -- )
    0 DO
        [CHAR] - EMIT
    LOOP CR
;
    CR 9 PLOT# 37 PLOT#
If you want to access the loop counter you can use the word I . Here is a simple word that dumps numbers and their associated ASCII characters. 
    : .ASCII ( end start -- , dump characters )
    DO
        CR I . I EMIT
    LOOP CR
;
    80 64 .ASCII
If you want to leave a DO LOOP before it finishes, you can use the word LEAVE. Enter: 
    : TEST.LEAVE  ( -- , show use of leave )
    100 0
    DO
        I . CR  \ print loop index
        I 20 >  \ is I over 20
        IF
            LEAVE
        THEN
    LOOP
;
TEST.LEAVE  \ will print 0 to 20
Please consult the manual to learn about the following words +LOOP and RETURN . FIXME

Another useful looping construct is the BEGIN WHILE REPEAT loop. This allows you to make a test each time through the loop before you actually do something. The word WHILE will continue looping if the flag on the stack is True. Enter: 

    : SUM.OF.N ( 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
;
    4 SUM.OF.N    \ prints 10   ( 1+2+3+4 )

Problems:

1) Rewrite SUM.OF.N using a DO LOOP.

2) Rewrite SUM.OF.N using BEGIN UNTIL.

3) For bonus points, write SUM.OF.N without using any looping or conditional construct!

Answers to the problems can be found at the end of this tutorial.

Text Input and Output

You learned earlier how to do single character I/O. This section concentrates on using strings of characters. You can embed a text string in your program using S". Note that you must follow the S" by one space. The text string is terminated by an ending " .Enter: 
    : TEST S" Hello world!" ;
TEST .S
Note that TEST leaves two numbers on the stack. The first number is the address of the first character. The second number is the number of characters in the string. You can print the characters of the string as follows. 
    TEST DROP       \ get rid of number of characters
DUP C@ EMIT     \ prints first character, 'H'
CHAR+ DUP C@ EMIT  \ prints second character, 'e'
\ and so on
CHAR+ advances the address to the next character. You can print the entire string using TYPE. 
    TEST  TYPE
TEST  2/  TYPE   \ print half of string
It would be nice if we could simply use a single address to describe a string and not have to pass the number of characters around. 'C' does this by putting a zero at the end of the string to show when it ends. Forth has a different solution. A text string in Forth consists of a character count in the first byte, followed immediately by the characters themselves. This type of character string can be created using the Forth word C" , pronounced 'c quote'. Enter: 
    : T2 C" Greetings Fred" ;
T2 .
The number that was printed was the address of the start of the string. It should be a byte that contains the number of characters. Now enter: 
    T2 C@ .
You should see a 14 printed. Remember that C@ fetches one character/byte at the address on the stack. You can convert a counted Forth string to an address and count using COUNT. 
    T2 COUNT .S
TYPE
The word COUNT extracts the number of characters and their starting address. COUNT will only work with strings of less than 256 characters, since 255 is the largest number that can be stored in the count byte. TYPE will, however, work with longer strings since the length is on the stack. Their stack diagrams follow:

CHAR+ ( address -- address' , add the size of one character )

COUNT ( $addr -- addr #bytes , extract string information ) 

TYPE ( addr #bytes -- , output characters at addr )

The $addr is the address of a count byte. The dollar sign is often used to mark words that relate to strings.

You can easily input a string using the word ACCEPT. (You may want to put these upcoming examples in a file since they are very handy.) The word ACCEPT receives characters from the keyboard and places them at any specified address. ACCEPT takes input characters until a maximum is reached or an end of line character is entered. ACCEPT returns the number of characters entered. You can write a word for entering text. Enter: 

    : INPUT$ ( -- $addr )
    PAD  1+ ( leave room for byte count )
    127 ACCEPT ( recieve a maximum of 127 chars )
    PAD C! ( set byte count )
    PAD ( return address of string )
;
    INPUT$ COUNT TYPE
Enter a string which should then be echoed. You could use this in a program that writes form letters. 
    : FORM.LETTER ( -- )
    ." Enter customer's name." CR
    INPUT$
    CR ." Dear " DUP COUNT TYPE CR
    ." Your cup that says " COUNT TYPE
    ." is in the mail!" CR
;
ACCEPT ( addr maxbytes -- numbytes , input text, save at address ) 

You can use your word INPUT$ to write a word that will read a number from the keyboard. Enter: 

    : INPUT# ( -- N true | false )
    INPUT$ ( get string )
    NUMBER? ( convert to a string if valid )
    IF DROP TRUE ( get rid of high cell )
    ELSE FALSE
    THEN
;
This word will return a single-precision number and a TRUE, or it will just return FALSE. The word NUMBER? returns a double precision number if the input string contains a valid number. Double precision numbers are 64-bit so we DROP the top 32 bits to get a single-precision 32 bit number.

Changing Numeric Base

Our numbering system is decimal, or "base 10." This means that a number like 527 is equal to (5*100 + 2*10 + 7*1). The use of 10 for the numeric base is a completely arbitrary decision. It no doubt has something to do with the fact that most people have 10 fingers (including thumbs). The Babylonians used base 60, which is where we got saddled with the concept of 60 minutes in an hour. Computer hardware uses base 2, or "binary". A computer number like 1101 is equal to (1*8 + 1*4 + 0*2 + 1*1). If you add these up, you get 8+4+1=13 . A 10 in binary is (1*2 + 0*1), or 2. Likewise 10 in any base N is N .

Forth makes it very easy to explore different numeric bases because it can work in any base. Try entering the following: 

    DECIMAL 6 BINARY .
1 1 + .
1101 DECIMAL .
Another useful numeric base is hexadecimal. which is base 16. One problem with bases over 10 is that our normal numbering system only has digits 0 to 9. For hex numbers we use the letters A to F for the digits 10 to 15. Thus the hex number 3E7 is equal to (3*256 + 14*16 + 7*1). Try entering: 
    DECIMAL 12 HEX .  \ print C
DECIMAL 12 256 *   7 16 * +  10 + .S
DUP BINARY .
HEX .
A variable called BASE is used to keep track of the current numeric base. The words HEX , DECIMAL , and BINARY work by changing this variable. You can change the base to anything you want. Try: 
    7 BASE !
6 1 + .
BASE @ . \ surprise!
You are now in base 7 . When you fetched and printed the value of BASE, it said 10 because 7, in base 7, is 10.

PForth defines a word called .HEX that prints a number as hexadecimal regardless of the current base. 

    DECIMAL 14 .HEX
You could define a word like .HEX for any base. What is needed is a way to temporarily set the base while a number is printed, then restore it when we are through. Try the following word: 
    : .BIN ( N -- , print N in Binary )
    BASE @ ( save current base )
    2 BASE ! ( set to binary )
    SWAP . ( print number )
    BASE ! ( restore base )
;
    DECIMAL
22 .BIN
22 .

Answers to Problems

If your answer doesn't exactly match these but it works, don't fret. In Forth, there are usually many ways to the same thing.

Stack Manipulations

    1) SWAP DUP
2) ROT DROP
3) ROT DUP 3 PICK
4) SWAP OVER 3 PICK
5) -ROT 2DUP

Arithmetic

    (12 * (20 - 17)) ==> 20 17 - 12 *
(1 - (4 * (-18) / 6)) ==> 1 4 -18 * 6 / -
(6 * 13) - (4 * 2 * 7) ==> 6 13 * 4 2 * 7 * -
    : SQUARE ( N -- N*N ) 
    DUP *
;
    : DIFF.SQUARES ( A B -- A*A-B*B )
SWAP SQUARE 
SWAP SQUARE - 
;
    : AVERAGE4 ( A B C D -- [A+B+C+D]/4 )
    + + + ( add'em up )
    -2 ashift ( divide by four the fast way, or 4 / )
;
    : HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS )

        -ROT SWAP ( -- seconds minutes hours )
        60 * + ( -- seconds total-minutes )
        60 * + ( -- seconds )
    ; 

Logical Operators

    : LOWERCASE? ( CHAR -- FLAG , true if lowercase )
    DUP 123 <
    SWAP 96 > AND
;

Conditionals

    : DEDUCT ( n -- , subtract from account )
    ACCOUNT @ ( -- n acc 
    SWAP - DUP ACCOUNT ! ( -- acc' , update variable )
    ." Balance = $" DUP . CR ( -- acc' )
    0< ( are we broke? )
    IF ." Warning!! Your account is overdrawn!" CR
    THEN
;

Loops

    : SUM.OF.N.1 ( 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.2 ( N -- SUM[N] )
    0 \ starting value of SUM
    BEGIN ( -- N' SUM )
        OVER +
        SWAP 1- SWAP
        OVER 0<
    UNTIL
    SWAP DROP
;
    : SUM.OF.N.3 ( NUM -- SUM[N] , Gauss' method )
    DUP 1+   \ SUM(N) = N*(N+1)/2
    * 2/
;
Back to pForth Home Page pforth-21/docs/pf_todo.txt100664 1750 1750 7033 6577771340 14371 0ustar bdalebdale\ %Z% %M% %E% %I% File: pf_todo.txt To Do -------------------------------------------------------- User Requests Peter Verbeke & Carmen Lams search wordset, float ext wordset , file wordset BUGS O- Fix NUMBER? in tutorial HIGH X- Add compile time selection for LittleEndian, BigEndian, or native dictionaries. X- detect and report endian conflicts in dictionary. O- add deferred user break to trace, allow stop, dump O- document more glossary words in pf_glos.htm O- pfInit() pfTerm(), pfTask() O- note that Special Feature" are the non-ANS words in document O- document stack diagram of words used with if.forgotten X- make sure "binary -1 u." is fixed, is string long enough? MEDIUM O- fix SAVE-INPUT and RESTORE-INPUT O- add ENVIRONMENT? O- fix t_corex.fth failures O- go through ANSI and add what's missing O- support more word sets O- support ANSI error codes O- add INCLUDED O- add better command line support, -d -e"commands" -i -b O- document all non-standard words O- review tutorial and docs LOW O- primitive that accepts, SP RSP and CFA, returns SP' and RSP' O- merge (LEAVE) and UNLOOP O- clear data stack in ABORT O- resolve problems with EOL in WORD O- integrate SAVE-FORTH, SDAD, and CLONE O- simplify dictionary management so that globals are tracked better O- move globals into task data structure O- research ROM requirements O- clean up C call mechanism O- research byte size tokens O- execute Forth QUIT automatically Maybe Do --------- O- defer interpret Done ------------- V19 X- warn if local name matches dictionary, : foo { count -- } ; X- TO -> and +-> now parse input stream. No longer use to-flag. X- TO -> and +-> now give error if used with non-immediate word. X- high level trace tool with step, alternative stack X- ?TERMINAL stub for embedded machines X- FIXED memory leak in pfDoForth() X- Add PF_USER_INIT for custom initialization. X- remove MM.FREE from docs X- include trace in normal release and document V18 X- Make FILL a 'C' primitive. X- optimized locals with (1_LOCAL@) X- optimized inner interpreter by 15% X- fix tester.fth failures X- Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined. X- Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition. X- Fixed saving and restoring of TIB when nesting include files. V16 X- add dictionary room to MAP command X- fix UM/MOD X- corex to kernel X- COMPARE to kernel X- integrate CATCH with ABORT and INTERPRET X- add WORDS.LIKE X- add list and description of files to README X- get floats to work with :STRUCT and FLPT X- add PD disclaimers to Forth code X- make script to build release package for UNIX/Mac X- clean up source files X- bump version number X- add PD disclaimers to 'C' code X- conditionally compile modes: full_build, compiler, turnkey X- save as turnkey or dev mode X- eliminate reliance on printf() for embedded systems X- funnel ALL I/O through pf_io.c X- add LoadDictionary X- add SAVEFORTH X- Add numeric entry X- call deferred word from Interpret X- Create Does X- Branch, 0branch X- add decimal numeric output X- add "OK" X- FIX EMIT !!!!! defer problem?! X- try to load dspp_asm.fth X- dictionary traversal, nfa->ffa X- fix BYE X- add CATCH and THROW X- REFILL X- SOURCE-ID X- EVALUATE X- push and pop source-id X- make .S deferred, redefine using current base X- revise trace to use level, stack trace X- allow minnamesize and mincodesize on save X- handle decimal point for double precision words. pforth-21/docs/pfmanual.txt100664 1750 1750 7360 6512256746 14542 0ustar bdalebdaleUNFINISHED Manual for pForth - a Portable Forth The best reference for pForth is an ANSI Forth manual. pForth is built on an ANSI model. There are, however, some non-standard words which are documented here: { ( i*x -- , declare local variables ) Local variables are only usable within a colon definition. They are taken from the stack as they are defined. They are self fetching. Use -> to set them. They help you avoid excessive stack dancing. Here is an example: : SUMSQ { aa bb -- } aa aa * bb bb * + ; 3 4 SUMSQ . ( prints 25 ) Here is an example of using a temporary variable: : SUMN { num | sum -- , sum up integers the dumb way } 0 -> sum \ uses -> to set local variable num 0 DO i sum + -> sum \ write current TOS to sum LOOP sum ; :STRUCT ( -- , defines a 'C' like structure ) See end of "c_struct.fth" for an example. ANEW ( -- ) Forgets NAME if it is already defined. Then defines NAME. Put at beginning of file so that file can be INCLUDEd multiple times without redefining the contents. CASE OF ENDOF ENDCASE in the typical fashion. See "case.fth" CHOOSE ( range -- random , pick random number, 0...range-1 ) IF ELSE THEN DO LOOP etc. can be used outside colon definitions! IF.FORGOTTEN ( -- , executes NAME if forgotten ) Put this at the end of a file to automatically call your cleanup word if the code is forgotten. INCLUDE ( -- , interpret from file ) Write your Forth programs in a file then load them using INCLUDE. INCLUDE myprog.fth INCLUDE? ( -- , interpret from file if needed ) INCLUDE the given file only if the named word is undefined. The name should be of a Forth word defined in the file. See "load_pforth.fth" for an example. INCLUDE? DO.MY.PROG myprog.fth MAP ( -- , dumps info about dictionary ) Other words FP.INIT FP.TERM F>S S>F EXISTS? STRINGS= S@ S! ;STRUCT :STRUCT STRUCT ULONG RPTR APTR FLPT USHORT UBYTE LONG SHORT BYTE BYTES SIZEOF() OB.STATS? OB.STATS OB.FINDIT OB.MEMBER }UNION }UNION{ UNION{ OB.MAKE.MEMBER MAP .HEX .DEC .BIN ARRAY WARRAY BARRAY -2SORT 2SORT WCHOOSE CHOOSE RANDOM RAND-SEED MSEC MSEC-DELAY VALUE -> TO -- strings -- TEXTROM $ROM $APPEND.CHAR INDEX $MATCH? TEXT=? TEXT= $= COMPARE $ARRAY -- case -- ENDCASE ENDOF RANGEOF (RANGEOF?) OF ?OF CASE OF-DEPTH CASE-DEPTH TOLOWER @EXECUTE >NAME CLOSEST-XT CLOSEST-NFA TAB TAB-WIDTH .HX $ CR? #COLS ?PAUSE ABORT" WARNING" CELL* << >> TASK-MISC1.FTH .R . (.) (NUMBER?) ((NUMBER?)) NUM_TYPE_DOUBLE NUM_TYPE_SINGLE NUM_TYPE_BAD >NUMBER DIGIT ANEW FORGET [FORGET] IF.FORGOTTEN SAVE-FORTH INCLUDE? RI INCLUDE $INCLUDE $APPEND LWORD PARSE PARSE-WORD PLACE WHAT'S IS DEFER >NEWLINE 0SP SPACES SPACE RECURSE UNLOOP -- user stack -- 0USP US@ US> >US USTACK 0STACKP STACK@ STACK> >STACK :STACK -- address storage and translation -- A, A@ A! IF.REL->USE IF.USE->REL X! X@ >ABS >REL REL->USE USE->REL BODY> >BODY N>LINK CODE> >CODE NAME> NAMEBASE+ CODEBASE NAMEBASE N>NEXTLINK >NAME PREVNAME NAME> ID. OFF ON TRACE-STACK TRACE-LEVEL TRACE-FLAGS HEADERS-BASE HEADERS-PTR ECHO CODE-BASE POP-SOURCE-ID PUSH-SOURCE-ID SOURCE-ID SET-SOURCE SOURCE LOADSYS FLUSHEMIT FINDNFA BYE BODY_OFFSET BAIL ARSHIFT pforth-21/pcbuild/ 40775 1750 1750 0 6462156704 12562 5ustar bdalebdalepforth-21/pcbuild/pForth.dsp100664 1750 1750 17755 6600017060 14651 0ustar bdalebdale# Microsoft Developer Studio Project File - Name="pForth" - Package Owner=<4> # Microsoft Developer Studio Generated Build File, Format Version 5.00 # ** DO NOT EDIT ** # TARGTYPE "Win32 (x86) Console Application" 0x0103 CFG=pForth - Win32 MakeDic !MESSAGE This is not a valid makefile. To build this project using NMAKE, !MESSAGE use the Export Makefile command and run !MESSAGE !MESSAGE NMAKE /f "pForth.mak". !MESSAGE !MESSAGE You can specify a configuration when running NMAKE !MESSAGE by defining the macro CFG on the command line. For example: !MESSAGE !MESSAGE NMAKE /f "pForth.mak" CFG="pForth - Win32 MakeDic" !MESSAGE !MESSAGE Possible choices for configuration are: !MESSAGE !MESSAGE "pForth - Win32 Release" (based on "Win32 (x86) Console Application") !MESSAGE "pForth - Win32 Debug" (based on "Win32 (x86) Console Application") !MESSAGE "pForth - Win32 MakeDic" (based on "Win32 (x86) Console Application") !MESSAGE # Begin Project # PROP Scc_ProjName "" # PROP Scc_LocalPath "" CPP=cl.exe RSC=rc.exe !IF "$(CFG)" == "pForth - Win32 Release" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release" # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c # ADD CPP /nologo /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c # ADD BASE RSC /l 0x409 /d "NDEBUG" # ADD RSC /l 0x409 /d "NDEBUG" BSC32=bscmake.exe # ADD BASE BSC32 /nologo # ADD BSC32 /nologo LINK32=link.exe # ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 # ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 /out:"../pForth.exe" !ELSEIF "$(CFG)" == "pForth - Win32 Debug" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug" # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c # ADD CPP /nologo /W4 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c # ADD BASE RSC /l 0x409 /d "_DEBUG" # ADD RSC /l 0x409 /d "_DEBUG" BSC32=bscmake.exe # ADD BASE BSC32 /nologo # ADD BSC32 /nologo LINK32=link.exe # ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept # ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept !ELSEIF "$(CFG)" == "pForth - Win32 MakeDic" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "pForth__" # PROP BASE Intermediate_Dir "pForth__" # PROP BASE Ignore_Export_Lib 0 # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "pForth__" # PROP Intermediate_Dir "pForth__" # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c # ADD CPP /nologo /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c # ADD BASE RSC /l 0x409 /d "_DEBUG" # ADD RSC /l 0x409 /d "_DEBUG" BSC32=bscmake.exe # ADD BASE BSC32 /nologo # ADD BSC32 /nologo LINK32=link.exe # ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept # ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept !ENDIF # Begin Target # Name "pForth - Win32 Release" # Name "pForth - Win32 Debug" # Name "pForth - Win32 MakeDic" # Begin Group "Forth" # PROP Default_Filter ".fth, .j" # Begin Source File SOURCE=..\ansilocs.fth # End Source File # Begin Source File SOURCE=..\bench.fth # End Source File # Begin Source File SOURCE=..\c_struct.fth # End Source File # Begin Source File SOURCE=..\case.fth # End Source File # Begin Source File SOURCE=..\catch.fth # End Source File # Begin Source File SOURCE=..\condcomp.fth # End Source File # Begin Source File SOURCE=..\coretest.fth # End Source File # Begin Source File SOURCE=..\filefind.fth # End Source File # Begin Source File SOURCE=..\floats.fth # End Source File # Begin Source File SOURCE=..\forget.fth # End Source File # Begin Source File SOURCE=..\loadp4th.fth # End Source File # Begin Source File SOURCE=..\locals.fth # End Source File # Begin Source File SOURCE=..\math.fth # End Source File # Begin Source File SOURCE=..\member.fth # End Source File # Begin Source File SOURCE=..\misc1.fth # End Source File # Begin Source File SOURCE=..\misc2.fth # End Source File # Begin Source File SOURCE=..\numberio.fth # End Source File # Begin Source File SOURCE=..\private.fth # End Source File # Begin Source File SOURCE=..\quit.fth # End Source File # Begin Source File SOURCE=..\see.fth # End Source File # Begin Source File SOURCE=..\smart_if.fth # End Source File # Begin Source File SOURCE=..\strings.fth # End Source File # Begin Source File SOURCE=..\system.fth # End Source File # Begin Source File SOURCE=..\t_alloc.fth # End Source File # Begin Source File SOURCE=..\t_corex.fth # End Source File # Begin Source File SOURCE=..\t_locals.fth # End Source File # Begin Source File SOURCE=..\t_strings.fth # End Source File # Begin Source File SOURCE=..\t_tools.fth # End Source File # Begin Source File SOURCE=..\tester.fth # End Source File # Begin Source File SOURCE=..\trace.fth # End Source File # Begin Source File SOURCE=..\tut.fth # End Source File # Begin Source File SOURCE=..\wordslik.fth # End Source File # End Group # Begin Group "docs" # PROP Default_Filter ".txt, .htm" # Begin Source File SOURCE=..\docs\pf_ref.htm # End Source File # Begin Source File SOURCE=..\docs\pf_todo.txt # End Source File # Begin Source File SOURCE=..\docs\pf_tut.htm # End Source File # Begin Source File SOURCE=..\docs\pfmanual.txt # End Source File # Begin Source File SOURCE=..\README.txt # End Source File # End Group # Begin Source File SOURCE=..\csrc\pf_cglue.c # End Source File # Begin Source File SOURCE=..\csrc\pf_clib.c # End Source File # Begin Source File SOURCE=..\csrc\pf_core.c # End Source File # Begin Source File SOURCE=..\csrc\pf_inner.c # End Source File # Begin Source File SOURCE=..\csrc\pf_io.c # End Source File # Begin Source File SOURCE=..\csrc\pf_main.c # End Source File # Begin Source File SOURCE=..\csrc\pf_mem.c # End Source File # Begin Source File SOURCE=..\csrc\pf_save.c # End Source File # Begin Source File SOURCE=..\csrc\pf_text.c # End Source File # Begin Source File SOURCE=..\csrc\pf_words.c # End Source File # Begin Source File SOURCE=..\csrc\pfcompil.c # End Source File # Begin Source File SOURCE=..\csrc\pfcustom.c # End Source File # End Target # End Project pforth-21/pcbuild/pForth.dsw100664 1750 1750 1027 6430644530 14632 0ustar bdalebdaleMicrosoft Developer Studio Workspace File, Format Version 5.00 # WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! ############################################################################### Project: "pForth"=.\pForth.dsp - Package Owner=<4> Package=<5> {{{ }}} Package=<4> {{{ }}} ############################################################################### Global: Package=<5> {{{ }}} Package=<3> {{{ }}} ############################################################################### pforth-21/pcbuild/pForth.ncb100664 1750 1750 142000 6600017056 14630 0ustar bdalebdaleMicrosoft C/C++ program database 2.00 JG1ö˜÷/ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿd¹ ; VÑ Zj o ž¤°Áßãö°Áƒó‘0¼*6ð$÷$÷4÷d " "° <?– 7:o -3 Fl %*27¤©¤©R|†hRXahd ##Ç Üëö *+Ý )*] 03A -0 +,& ,-‡e 56k 34 a 67 Æÿ :; Ð) ;E } 45 · 9:™r 78¨ 89’ ªÖ) X‚l —¡ò PUF E¥J ˆ’  5"ß EJ#< =@% &  'Ö ñô)ç úý+í êžSž/2w2222222 ¥·ê3ííÿžPe}íWž&ííWžžíÿíòd í ­­ª Ž«Ñ ¶íµÅíàd ™ •–® –˜3o A|* (- 7:  *2 kl ËÐá ¦ª¸ ˜Ä Ÿ¥l «³;l ½Ä`l ÅÊ ‰ Š!| †‰"j …$/l ´¼)¢¢2<JVí©2í7%žížížV¢&Ïž "ížíFUžíxxx©ž "í i « !!· ""– Á *exÆÏd Ue5:@*/3ÚŽ’ '/… |± „j ds ?o \b ,N TZÑ LRŠ FJwe tzf ?DË ŒŽÂ ‹Œû* M 'æ ˜¥U  ESG  @!`  Xf#ñ ¬ò&  ù)&í–åí–åžKíKíåíåí—´íKísžUwíw w íj íþ í+ 7 d )  ~~” ; ÍÒ” k{  x„Ä  ” æ  Œ• Õ [ MQ §  FJ þ < SW \\  ^h‡ ; äôI  ku­  ‡‘ b ; Øá#Ú  ¥­&5  ¹Á)  °¶,K  ÃÉ/§  Š4§ ; ûˆ9þ  ŽÒ<þ  ˜v?xxŽ — Ž — žl ï ê º Á º Á í% : í% : žl ’ › í] m í] m žl } íí û íí û í ) í ) ž&³ È × ž&³ È × & & d ¸  p|Q  Ó÷˜  ü ‰  bk­  '2  ÑÓ  ±ËÇ  ‚’ÿ / ˜«U  "[!w˜ Wwe o z ‰ í+ £ w˜ £ í¶ : žÕ  å ' žÕ å õ žÕ å õ íc } d, 4 ›è   î  &*÷  -GE ž» - h†þ  Jem ÂÞ2©í%í%í2Ob2©2©w©dr j ”  CO++– ty–33 Æ Cfâ kpO ÔOl..8à ™¤ò vˆ, Œ”º 6<1 es1E,,w ©®"” ¯³$h (1%s &s//'‚ %(‚e00) 3>*F ,, ñ.: \e/þ %1Q }†2² »Ð4É Ýî7àø óø:¢ ­Ö=e ¡¥>ä •¤@Ì !?A¨ ´¸CØ B`D ÑìE  «ËGÝ yHp 6OIY žJö**Lö *.N QYPC gqSw †§VDß--WD ‰ŒXÒ !#Y¡d !Zà #$[ìI $*\G ª_žží¦ãí¦ãíàÕíàãÕí^í^žSžc ííí‚‹íŸížžííí¢`2ííííí¾2¬Ð2èÐ2¬…í2òžíŸí¢ßòí2íííí-í¦2à…í힯SS Y× d ™ %)™m  +0  ó nn ó ^l o[ PT o ACÛ CHž} ž} í§²í§²ß߃¼ß    - DÑ € ªo)5°@€@Tøÿ5ck¾F+@@ @ @A@ºÃÜ5Ší @vÝ5‚úk)ˆ@ @€€ ! à!5wÁ! à!5 Ý` )ˆ@‚‚@„ Hˆ€ à!5u ) ?  € @B ‚ÿÿ56 ­ ! @€@.*6È m ¬(„ˆÜ5tp8_$@R@¢€D  P ALE…ˆ„@Þùÿ5yó P Â'6þïþï pForth - Win32 MakeDicpForth - Win32 DebugpForth - Win32 ReleaseE:\nomad\pForth\csrc\pf_cglue.c"pf_all.h"CustomFunctionTablevoid* [ ]CallUserFunctionint32int32 Indexint32 ReturnModeint32 NumParamsCreateGlueToCErrconst char * CNameuint32 IndexE:\nomad\pForth\csrc\pf_clib.cpfCStringLengthcellconst char * spfSetMemoryvoid*void * scell ccell npfCopyMemoryvoid * s1const void * s2pfCharToUppercharchar cpfCharToLowerE:\nomad\pForth\csrc\pf_core.cgCurrentTaskcfTaskData*gCurrentDictionarycfDictionary*gNumPrimitivesgScratchchar [ TIB_SIZE ]gLocalCompiler_XTExecTokengDepthAtColongVarContextchar*gVarStategVarBasegVarEchogVarTraceLevelgVarTraceStackgVarTraceFlagsgVarQuietgVarReturnCodepfInitGlobalsvoidpfDeleteTaskcfTaskData * cftdpfCreateTaskint32 UserStackDepthint32 ReturnStackDepthpfExecByNameconst char * CStringpfDeleteDictionarycfDictionary * dicpfCreateDictionaryuint32 HeaderSizeuint32 CodeSizeResetForthTaskpfSetCurrentTaskpfSetQuietint32 IfQuietpfQueryQuietpfRunForthpfIncludeFileconst char * FileNamepfMessagepfDoForthconst char * DicNameconst char * SourceNameint32 IfInitE:\nomad\pForth\csrc\pf_inner.cTraceNamesExecToken Tokenint32 LevelpfExecuteTokenExecToken XT"pfinnrfp.h"E:\nomad\pForth\csrc\pf_io.cioEmitioTypeint32 nioKeyioAcceptchar * Targetcell MaxLenFileStream * streamsdTerminalOutintsdTerminalInsdTerminalFlushPF_STDINFileStream*PF_STDOUTsdInputCharsdOpenFileconst char * ModesdFlushFileFileStream * StreamsdReadFilevoid * ptrint32 Sizeint32 nItemssdWriteFilesdSeekFileint32 Positionint32 ModesdTellFilesdCloseFileE:\nomad\pForth\csrc\pf_main.c"pforth.h"mainint argcchar * * argvE:\nomad\pForth\csrc\pf_mem.cgMemPoolPtrgMemPoolSizeuint32MemoryPoolchar [ PF_MEM_POOL_SIZE ]DoublyLinkedListNodeDoublyLinkedListdllSetupListDoublyLinkedList * dlldllLinkNodesDoublyLinkedListNode * Node0DoublyLinkedListNode * Node1dllInsertNodeBeforeDoublyLinkedListNode * NewNodePtrDoublyLinkedListNode * NodeInListPtrdllInsertNodeAfterdllDumpNodeDoublyLinkedListNode * NodePtrdllCheckNodedllRemoveNodedllAddNodeToHeadDoublyLinkedList * ListPtrdllAddNodeToTailgMemListgIfMemListInitMemListNodemaDumpListpfFreeRawMemchar * Memint32 NumBytespfInitMemAllocatorvoid * addruint32 poolSizepfAllocRawMempfAllocMempfFreeMemvoid * MemE:\nomad\pForth\csrc\pf_save.cIsHostLittleEndianReadShortBigEndianuint16const uint16 * addrReadLongLittleEndianconst uint32 * addrReadShortLittleEndianReverseCopyFloatconst PF_FLOAT * srcPF_FLOAT * dstWriteFloatBigEndianPF_FLOAT * addrPF_FLOAT dataReadFloatBigEndianPF_FLOATconst PF_FLOAT * addrWriteFloatLittleEndianReadFloatLittleEndianWriteLongBigEndianuint32 * addruint32 dataWriteShortBigEndianuint16 * addruint16 dataWriteLongLittleEndianWriteShortLittleEndianWriteLongFileStream * fidint32 ValWriteChunkint32 IDchar * DataffSaveForthExecToken EntryPointint32 NameSizeint32 CodeSizeReadLongint32 * ValPtrpfLoadDictionaryExecToken * EntryPointPtr"pfdicdat.h"E:\nomad\pForth\csrc\pf_text.cpfReportErrorconst char * FunctionNameErr ErrCodeForthStringToCchar * dstconst char * FStringCStringToForthffCompareTextconst char * s1const char * s2int32 lenffCompareTextCaseNffCompareint32 len1int32 len2cnttPadchar [ CNTT_PAD_SIZE ]ConvertNumberToTextint32 Numint32 Baseint32 IfSignedint32 MinCharsDumpMemoryint32 cntTypeNameconst char * NameE:\nomad\pForth\csrc\pf_words.cffDotffDotHexffDotSffSkipchar * AddrIncell Cntchar * * AddrOutffScanHexDigitToNumberffNumberQconst char * FWordcell * NumffWordE:\nomad\pForth\csrc\pfcompil.c"pfcompil.h"gIncludeStackIncludeFrame [ MAX_INCLUDE_DEPTH ]gIncludeIndexgNumberQ_XTgQuitP_XTffStringColonconst ForthStringPtr FNameCheckRedefinitionReportIncludeStateffUnSmudgeFindAndCompileconst char * theWordffCheckDicRoomffCleanIncludeStackCreateDeferredCExecToken DefaultXTNotCompiledCreateDicEntryuint32 FlagsCreateDicEntryCNameToPreviousconst ForthString*const ForthString * NFANameToTokenFindSpecialXTspfBuildDictionaryint32 HeaderSize"pfcompfp.h"ffTokenToNameconst ForthString * * NFAPtrffFindNFAconst ForthString * WordNameffFindExecToken * pXTffFindCconst char * WordNameffCreateSecondaryHeaderffColonffStringCreatechar * FNameffCreateffStringDeferffDeferffSemiColonffFinishSecondaryff2Literalcell dHicell dLoffALiteralcell NumffLiteralffFPLiteralPF_FLOAT fnumffInterpretffOKffQuitffIncludeFileFileStream * InputFileffPushInputStreamffPopInputStreamffConvertStreamToSourceIDffConvertSourceIDToStreamcell idffAbortffRefillE:\nomad\pForth\csrc\pfcustom.cCTest0CTest1int32 Val1cell Val2void* [ NUM_CUSTOM_FUNCTIONS ]LoadCustomFunctionTableCompileCustomFunctionsØyJ¢w¬/e úËò·£ Á b D@P) Æm xj¡—<3;,ê ™I t %ƒÐ]þ Ñ°þ¸F ÌV}j` - Q Õ ísØòU –&ä‹ ™‡–™íòÛŠŽ ” ¤+ |) ¥6 ß› % þ ö‚ÐæàÏ&^wQpãeÈ R†f2 wÝÝû/íOK`Y `§ªu — ÖU: k&”óW±} dDþ G’ ˜ ‚ö: «‰ Áþżɮ4 Æ m” ÷ …k h˜ j º Ú¶ ìî AßáÒ¾Õ å ’7 ¸ J2ï …× F‰ Y7à3b U 1{ Ýol ÇàÆ] h² Ï:¯ŸÇ K È  EÿÑè–¢Ä<­ CFõ æ ©¨²,¾êâe"òÚ -·§ 5 £ °–?í ‡ ÑFOjwç8ÿ å­ ³ sµ-Õ,UÁ}ñû ‰ö-l´·¨G o aŠ|Ä Sz ž§ "} ' c Xo ¤wº¦è Bó‘0¼*6¥/names/ncb/targetinfo/ncb/moduleinfo/ncb/module/E:\nomad\pForth\csrc\pf_cglue.c/ncb/module/E:\nomad\pForth\csrc\pf_clib.c/ncb/module/E:\nomad\pForth\csrc\pf_core.c/ncb/module/E:\nomad\pForth\csrc\pf_inner.c/ncb/module/E:\nomad\pForth\csrc\pf_io.c/ncb/module/E:\nomad\pForth\csrc\pf_main.c/ncb/module/E:\nomad\pForth\csrc\pf_mem.c/ncb/module/E:\nomad\pForth\csrc\pf_save.c/ncb/module/E:\nomad\pForth\csrc\pf_text.c/ncb/module/E:\nomad\pForth\csrc\pf_words.c/ncb/module/E:\nomad\pForth\csrc\pfcompil.c/ncb/module/E:\nomad\pForth\csrc\pfcustom.c/ncb/target/pForth - Win32 MakeDic/ncb/target/pForth - Win32 Debug/ncb/target/pForth - Win32 Release/ncb/versioninfo&Áxý~ ”© ©Õ'~) qSSPÕ -þ (ði÷$÷4÷~¨ÿ äö$÷hˆ÷˜ø÷ŒøT¸÷ÄÈ÷\Ø÷$lü||ü4Œüèœüü¨÷Üœþ¬þ¼þÌþ˜ÿ.'()*+,-#$% !"&pforth-21/pcbuild/pForth.opt100664 1750 1750 141000 6600017056 14667 0ustar bdalebdaleÐÏࡱá>þÿ þÿÿÿþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿ  þÿÿÿ þÿÿÿþÿÿÿK"#$%&'()*þÿÿÿ,-./0123456þÿÿÿ89:;<=>?@þÿÿÿBCDEFGHIJþÿÿÿþÿÿÿMNOPQRSTUþÿÿÿWXYZ[\]^_þÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿRoot Entryÿÿÿÿÿÿÿÿ€´3¸á½þÿÿÿWorkspace State  ÿÿÿÿBrowserÿÿÿÿ Editorÿÿÿÿÿÿÿÿpforth"E:\nomad\pForth\pcbuild\pForth.dspase-------------------- Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) Project's tools are: "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib olå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectli"E:\nomad\pForth\pcbuild\pForth.dspase-------------------- Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) Project's tools are: "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib olå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliMLJL"E:\nomad\pForth\pcbuild\pForth.dspase-------------------- Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) Project's tools are: "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib olå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliWorkspace Window"ÿÿÿÿÿÿÿÿ!IPI_pForthÿÿÿÿÿÿÿÿÿÿÿÿ+IPI_ ÿÿÿÿÿÿÿÿÿÿÿÿ7ClassView Window"ÿÿÿÿÿÿÿÿÿÿÿÿApForth ClassViewpForth classespForth classesFileView Workspace 'pForth': 1 project(s) Workspace 'pForth': 1 project(s) pForth filesInfoViewDeveloper ProductsDeveloper Products ClassViewr for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib olå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliYÃPFORTH - WIN32 RELEASE pForth.dspCProjectPFORTH - WIN32 RELEASEpForth - Win32 Releaseì../è ../pForth.exeûpForth - Win32 Debugì../êè ../pForth.exepForth - Win32 MakeDicì../è ../pForth.exeé -i system.fthêûSSBR CTargetItempForth - Win32 ReleasepForth - Win32 MakeDicSSBRForth CProjGroupSSBRDJWdocs CProjGroupSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hCDependencyFileSSBR pf_types.hCDependencyFileSSBR pf_win32.hCDependencyFileSSBR pf_clib.hCDependencyFileSSBR pf_unix.hCDependencyFileSSBR pf_float.hCDependencyFileSSBR pf_core.hCDependencyFileSSBR pfcompil.hCDependencyFileSSBR pfinnrfp.hCDependencyFileSSBRpforth.hCDependencyFileSSBR pfcompfp.hCDependencyFileSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hCDependencyFileSSBR pf_types.hCDependencyFileSSBR pf_win32.hCDependencyFileSSBR pf_clib.hCDependencyFileSSBR pf_unix.hCDependencyFileSSBR pf_float.hCDependencyFileSSBR pf_core.hCDependencyFileSSBR pfcompil.hCDependencyFileSSBR pfinnrfp.hCDependencyFileSSBRpforth.hCDependencyFileSSBR pfcompfp.hCDependencyFileSSBRDJWDJWDJWå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliå  ÌntÎh oleidl.h oleidl.idl olenls.h ostream ostream.h pbt.h pcrt32.h pdh.h pdhmsg.h penwin.h plan32.h poppack.h prnsetup.dlg process.h prsht.h pshpack1.h pshpack2.h pshpack4.h pshpack8.h queue ras.h rasdlg.h raserror.h rassapi.h rasshost.h recguids.h reconcil.h regstr.h res\3dcheck.bmp res\95check.bmp res\copy4way.cur res\help.cur res\help.rsc res\magnify.cur res\magnify.rsc res\minifwnd.bmp res\move4way.cur res\nodrop.cur res\ntcheck.bmp res\sarrows.cur res\split.rsc res\splith.cur res\splitv.cur res\trck4way.cur res\trcknesw.cur res\trckns.cur res\trcknwse.cur res\trckwe.cur res\truetype.bmp richedit.h richole.h rpc.h rpcdce.h rpcdcep.h rpcndr.h rpcnsi.h rpcnsip.h rpcnterr.h rpcproxy.h sarrows.cur scode.h scrnsave.h search.h sehmap.h servprov.h servprov.idl set setjmp.h setjmpex.h setupapi.h share.h shellapi.h shlguid.h shlobj.h signal.h smpab.h smpms.h smpxp.h snmp.h split.rsc splith.cur splitv.cur sporder.h sql.h sqlext.h sqltypes.h sqlucode.h sstream stack stat.h statreg.cpp statreg.h stdarg.h stddYÃpForthÿÿh.dspCProjectPFORTH - WIN32 RELEASEpForth - Win32 Releaseì../è ../pForth.exeûpForth - Win32 Debugì../êè ../pForth.exepForth - Win32 MakeDicì../è ../pForth.exeé -i system.fthêûSSBR CTargetItempForth - Win32 ReleasepForth - Win32 MakeDicSSBRForth CProjGroupSSBRDJWdocs CProjGroupSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliÿÿ CClsFldSlobpForthh.dspCProjectPFORTH - WIN32 RELEASEpForth - Win32 Releaseì../è ../pForth.exeûpForth - Win32 Debugì../êè ../pForth.exepForth - Win32 MakeDicì../è ../pForth.exeé -i system.fthêûSSBR CTargetItempForth - Win32 ReleasepForth - Win32 MakeDicSSBRForth CProjGroupSSBRDJWdocs CProjGroupSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectliDebuggerÿÿÿÿÿÿÿÿÿÿÿÿLDocumentsÿÿÿÿVÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ ÿÿÿÿWatch1Watch2Watch3Watch42 RELEASEpForth - Win32 Releaseì../è ../pForth.exeûpForth - Win32 Debugì../êè ../pForth.exepForth - Win32 MakeDicì../è ../pForth.exeé -i system.fthêûSSBR CTargetItempForth - Win32 ReleasepForth - Win32 MakeDicSSBRForth CProjGroupSSBRDJWdocs CProjGroupSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectlihÿÿÿÿWatch1Watch2Watch3Watch42 RELEASEpForth - Win32 Releaseì../è ../pForth.exeûpForth - Win32 Debugì../êè ../pForth.exepForth - Win32 MakeDicì../è ../pForth.exeé -i system.fthêûSSBR CTargetItempForth - Win32 ReleasepForth - Win32 MakeDicSSBRForth CProjGroupSSBRDJWdocs CProjGroupSSBRDJWdepCDependencyContainerSSBRpf_all.hCDependencyFileSSBR pf_cglue.hCDependencyFileSSBR pf_text.hCDependencyFileSSBRpf_mem.hCDependencyFileSSBR pf_guts.hCDependencyFileSSBR pf_save.hCDependencyFileSSBRpf_io.hCDependencyFileSSBR pf_words.hå ÌntÎhappguid.h objmodel\bldauto.h objmodel\blddefs.h objmodel\bldguid.h objmodel\dbgauto.h objmodel\dbgdefs.h objmodel\dbgguid.h objmodel\textauto.h objmodel\textdefs.h objmodel\textguid.h objsafe.h ocidl.h ocidl.idl odbcinst.h ole.h ole2.h ole2ver.h oleauto.h olectl.h olectlipforth-21/pcbuild/pForth.plg100664 1750 1750 4750 6600017036 14617 0ustar bdalebdale--------------------Configuration: pForth - Win32 Release-------------------- Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) Project's tools are: "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /incremental:no /pdb:"Release/pForth.pdb" /machine:I386 /out:"../pForth.exe" " "Custom Build" with flags "" "" with flags "" Creating temp file "C:\WINDOWS\TEMP\RSP62A2.TMP" with contents Creating command line "cl.exe @C:\WINDOWS\TEMP\RSP62A2.TMP" Creating temp file "C:\WINDOWS\TEMP\RSP62A3.TMP" with contents Creating command line "link.exe @C:\WINDOWS\TEMP\RSP62A3.TMP" Compiling... pf_cglue.c pf_clib.c pf_core.c pf_inner.c pf_io.c pf_main.c pf_mem.c pf_save.c pf_text.c pf_words.c pfcompil.c pfcustom.c Linking... pForth.exe - 0 error(s), 0 warning(s) pforth-21/utils/ 40775 1750 1750 0 6462156710 12275 5ustar bdalebdalepforth-21/utils/clone.fth100664 1750 1750 27075 6510350774 14230 0ustar bdalebdale\ @(#) 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 pforth-21/utils/dump_struct.fth100664 1750 1750 4635 6510350774 15456 0ustar bdalebdale\ @(#) 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. include? task-member 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 ) >rel [compile] dst ; 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 ..! along1 $ -665 afoo ..! ashort1 $ 21 afoo ..! abyte $ 43 afoo ..! abyte2 -234 afoo .. agoo ..! goo_height ; afoo.init : TDS ( afoo -- ) dst foo ; .THEN pforth-21/utils/load_file.fth100664 1750 1750 1561 6510350776 15020 0ustar bdalebdale\ 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 . pforth-21/utils/make_all256.fth100664 1750 1750 1640 6510350776 15102 0ustar bdalebdale\ @(#) 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 pforth-21/utils/savedicd.fth100664 1750 1750 6731 6567351662 14677 0ustar bdalebdale\ @(#) 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. 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 SAVE-DIC-AS-DATA */" $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 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 MinDicCode[] = {" sdad.type codebase here SDAD_CODE_EXTRA sdad.dump.data EOL sdad.emit c" };" $sdad.line sdad.close ; if.forgotten sdad.close ." Enter: SDAD" cr pforth-21/utils/trace.fth100664 1750 1750 26171 6461763706 14232 0ustar bdalebdale\ @(#) trace.fth 98/01/08 1.1 \ 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 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 30 space.to.column \ show data stack trace.show.stack 65 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 100 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 ." 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 down ) trace_level -> trace_level_max 0 ?DO trace_ip trace.next -> trace_ip LOOP ; : gd { more_levels | stop_level -- } depth 1 < IF ." GD requires a MORE_LEVELS parameter." cr ELSE trace_level more_levels + -> trace_level_max trace_level 1- -> stop_level BEGIN trace_ip trace.next -> trace_ip trace_level stop_level > not 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] pforth-21/c_struct.fth100664 1750 1750 14752 6510350766 13615 0ustar bdalebdale\ @(#) 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] pforth-21/case.fth100664 1750 1750 3373 6510350766 12657 0ustar bdalebdale\ @(#) 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 anew TASK-CASE variable CASE-DEPTH variable OF-DEPTH : CASE ( n -- , start case statement ) ( -c- case-depth ) ?comp case-depth @ case-depth off ( allow nesting ) 0 of-depth ! ; 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 ! ; IMMEDIATE pforth-21/catch.fth100664 1750 1750 2541 6510350766 13022 0ustar bdalebdale\ @(#) catch.fth 98/01/26 1.2 \ Catch and Throw support \ \ Lifted from X3J14 dpANS-6 document. anew task-catch.fth variable CATCH-HANDLER 0 catch-handler ! : CATCH ( xt -- exception# | 0 ) sp@ >r ( xt ) \ save data stack pointer catch-handler @ >r ( xt ) \ save previous handler rp@ catch-handler ! ( xt ) \ set current handler execute ( ) \ execute returns if no throw r> catch-handler ! ( ) \ restore previous handler r> drop ( ) \ discard saved stack pointer 0 ( ) \ normal completion ; : THROW ( ???? exception# -- ???? exception# ) ?dup ( exc# ) \ 0 THROW is a no-op IF catch-handler @ dup 0= IF ." THROW has noone to catch!" cr quit THEN rp! ( exc# ) \ restore prev return stack r> catch-handler ! ( exc# ) \ restore prev handler r> swap >r ( saved-sp ) \ exc# on return stack sp! drop r> ( exc# ) \ restore stack THEN \ return to caller of catch ; : (ABORT) ERR_ABORT throw ; defer old.abort what's abort is old.abort ' (abort) is abort : restore.abort what's old.abort is abort ; if.forgotten restore.abort hex : BAD.WORD -5 throw ; : NAIVE.WORD ( -- ) 7777 8888 23 . cr bad.word ." After bad word!" cr ; : CATCH.BAD ( -- ) ['] naive.word catch . ; : CATCH.GOOD ( -- ) 777 ['] . catch . cr ; decimal pforth-21/condcomp.fth100664 1750 1750 2574 6510350766 13550 0ustar bdalebdale\ @(#) 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 pforth-21/filefind.fth100664 1750 1750 3563 6510350766 13525 0ustar bdalebdale\ @(#) 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 : ODD@ { addr | val -- val , fetch from odd aligned address, IBM PCs??? } 4 0 DO addr i + c@ val 8 lshift or -> val LOOP val ; \ 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+ odd@ 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 ; pforth-21/floats.fth100664 1750 1750 24633 6564626704 13265 0ustar bdalebdale\ @(#) 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 0 s>f true 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 char 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 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] pforth-21/forget.fth100664 1750 1750 4767 6510350766 13242 0ustar bdalebdale\ @(#) 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 ; pforth-21/loadp4th.fth100664 1750 1750 2643 6510350766 13462 0ustar bdalebdale\ @(#) 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? catch catch.fth include? task-quit.fth quit.fth \ useful but optional stuff follows -------------------- include? [if] condcomp.fth \ load floating point support if basic support is in kernel exists? F* [IF] include? task-floats.fth floats.fth [THEN] 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 map pforth-21/locals.fth100664 1750 1750 3204 6510350766 13212 0ustar bdalebdale\ @(#) $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. 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 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 \ 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 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 ; pforth-21/system.fth100664 1750 1750 45367 6567074226 13327 0ustar bdalebdale: 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 \ This is another style of comment that is common in Forth. \ @(#) system.fth 98/01/26 1.4 \ ********************************************************************* \ 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 ! ; \ size of data items \ FIXME - move these into 'C' code for portability ???? : CELL ( -- size_of_stack_item ) 4 ; : CELL+ ( n -- n+cell ) cell + ; : CELL- ( n -- n+cell ) cell - ; : CELLS ( n -- n*cell ) 2 lshift ; : 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 ) 8 - ; : >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 : ERR_ABORT -1 ; \ general abort : ERR_CONDITIONAL -2 ; \ stack error during conditional : ERR_EXECUTING -3 ; \ compile time word while not compiling : ERR_PAIRS -4 ; \ mismatch in conditional : ERR_DEFER -5 ; \ not a deferred word : ERR_UNDERFLOW -6 ; \ Conditionals in '83 form ----------------------------------------- : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ; : ?CONDITION ( f -- ) conditional_key - err_conditional ?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 [compile] ; \ terminate part of code before does> :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 31 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 defer ABORT \ will default to QUIT : /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! ; \ ----------------------------------------------------------------- \ 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 dup >r \ save fid for close-file depth >r include-file depth 1+ r> - IF ." Warning: stack depth changed during include!" cr .s cr 0sp THEN r> close-file drop 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 ; \ load remainder of dictionary trace-include on trace-stack on 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 pforth-21/strings.fth100664 1750 1750 3520 6510350770 13422 0ustar bdalebdale\ @(#) 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 * + 4 + ; \ 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 ; \ ----------------------------------------------- pforth-21/smart_if.fth100664 1750 1750 3432 6510350770 13537 0ustar bdalebdale\ @(#) 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 pforth-21/see.fth100664 1750 1750 7213 6510350770 12510 0ustar bdalebdale\ @(#) 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] pforth-21/quit.fth100664 1750 1750 5175 6510350766 12730 0ustar bdalebdale\ @(#) quit.fth 98/01/26 1.2 \ Outer Interpreter in Forth \ \ This used so that THROW can be caught by QUIT. \ \ 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? catch catch.fth anew task-quit.fth : FIND&COMPILE ( $word -- {n} , find word in dictionary and handle it ) dup >r \ save in case needed find ( -- xt flag | $word 0 ) CASE -1 OF \ not immediate state @ \ compiling? IF compile, ELSE execute THEN ENDOF 1 OF execute \ immediate, so execute regardless of STATE ENDOF 0 OF number? \ is it a number? num_type_single = IF ?literal \ compile it or leave it on stack ELSE r@ count type ." is not recognized!!" cr abort THEN ENDOF ENDCASE rdrop ; : CHECK.STACK \ throw exception if stack underflows depth 0< IF ." QUIT: Stack underflow!" cr depth negate 0 \ restore depth ?DO 0 LOOP ERR_UNDERFLOW throw THEN ; \ interpret whatever is in source : INTERPRET ( ?? -- ?? ) BEGIN >in @ source nip ( 1- ) < \ any input left? !!! is -1 needed? WHILE bl word dup c@ 0> IF 0 >r \ flag local-compiler @ IF dup local-compiler @ execute ( ?? -- ?? ) r> drop TRUE >r THEN r> 0= IF find&compile ( -- {n} , may leave numbers on stack ) THEN ELSE drop THEN check.stack REPEAT ; : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) \ save current input state and switch to pased 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 ; : POSTPONE ( -- ) bl word find CASE 0 OF ." Postpone could not find " count type cr abort ENDOF 1 OF compile, ENDOF \ immediate -1 OF (compile) ENDOF \ normal ENDCASE ; immediate : OK ." OK " trace-stack @ IF .s ELSE cr THEN ; variable QUIT-QUIT : QUIT ( -- , interpret input until none left ) quit-quit off postpone [ BEGIN refill quit-quit @ 0= and WHILE \ ." TIB = " source type cr ['] interpret catch ?dup IF ." Exception # " . cr ELSE state @ 0= IF ok THEN THEN REPEAT ; pforth-21/private.fth100664 1750 1750 2072 6510350766 13411 0ustar bdalebdale\ @(#) 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 ! ; pforth-21/numberio.fth100664 1750 1750 10714 6567074330 13603 0ustar bdalebdale\ @(#) numberio.fth 98/01/26 1.2 \ numberic_io.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-numeric_io.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 drop 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 ; pforth-21/misc2.fth100664 1750 1750 10542 6510350766 12775 0ustar bdalebdale\ @(#) 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 1000 , ( default for SUN ) : msec ( #msecs -- ) 0 do msec-delay @ 0 do loop loop ; : 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 ; pforth-21/misc1.fth100664 1750 1750 5635 6510350766 12763 0ustar bdalebdale\ @(#) 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 ; : CELL* ( n -- n*cell ) 2 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 abort 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 32 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 ; 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 ; pforth-21/member.fth100664 1750 1750 11221 6510350766 13222 0ustar bdalebdale\ @(#) 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. 32 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 ; pforth-21/math.fth100664 1750 1750 3500 6510350766 12665 0ustar bdalebdale\ @(#) 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 ; pforth-21/tut.fth100664 1750 1750 2360 6417271106 12547 0ustar bdalebdaleanew 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 pforth-21/wordslik.fth100664 1750 1750 2153 6510350770 13570 0ustar bdalebdale\ @(#) 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 ; pforth-21/bench.fth100664 1750 1750 7632 6510350770 13020 0ustar bdalebdale\ @(#) 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 \ \ 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 pforth-21/coretest.fth100664 1750 1750 61660 6510350770 13612 0ustar bdalebdale\ 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?... 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 } pforth-21/t_alloc.fth100664 1750 1750 5140 6510350770 13346 0ustar bdalebdale\ @(#) 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 pforth-21/t_corex.fth100664 1750 1750 13702 6510350770 13417 0ustar bdalebdale\ @(#) 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 pforth-21/t_locals.fth100664 1750 1750 1200 6510350770 13522 0ustar bdalebdale\ @(#) 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{ echo off \ 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 pforth-21/t_strings.fth100664 1750 1750 6444 6510350770 13755 0ustar bdalebdale\ @(#) 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 pforth-21/t_tools.fth100664 1750 1750 3221 6510350770 13412 0ustar bdalebdale\ @(#) 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 ; pforth-21/tester.fth100664 1750 1750 3160 6510350770 13237 0ustar bdalebdale\ 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 ; pforth-21/ansilocs.fth100664 1750 1750 10765 6510350766 13602 0ustar bdalebdale\ @(#) 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. 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 @ [compile] literal compile (local.entry) ['] lv.compile.local local-compiler ! 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 pforth-21/README.txt100664 1750 1750 25366 6600014612 12750 0ustar bdalebdaleREADME for pForth - a Portable ANS-like Forth written in ANSI 'C' by Phil Burk with Larry Polansky, David Rosenboom and Darren Gibbs. Last updated: 4/6/98 V19 Please direct feedback, bug reports, and suggestions to: philburk@softsynth.com. The author is available for customization of pForth, porting to new platforms, or developing pForth applications on a contractual basis. If interested, contact Phil Burk at philburk@softsynth.com. -- 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. -- How to run PForth ------------------------------------ Note: Please refer to "pf_ref.htm" for more complete information. 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 run 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. -- Version History -------------------------------------- V1 - 5/94 - built pForth from various Forths including HMSL V2 - 8/94 - made improvements necessary for use with M2 Verilog testing 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. 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 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 V6 - 3/16/95 - Added floating point - Changed NUMBER? to return a numeric type - Support double number entry, eg. 234. -> 234 0 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 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. 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 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. ;-) 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. 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. 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". 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". 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). 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. V17 - Fixed input of large floats. 0.7071234567 F. used to fail. 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. V19 4/98 - 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() 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. V21 - Fixed some compiler warnings. Enjoy, Phil Burk pforth-21/siev.fth100664 1750 1750 1301 6435120422 12665 0ustar bdalebdale\ #! /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 ; pforth-21/bloop.fth100664 1750 1750 506 6435122122 13017 0ustar bdalebdale : BLOOP ( n -- n' ) 0 swap 0 DO i + i 1 and IF dup dup 2 + swap - drop THEN LOOP ; \ ." START" cr \ 8000000 bloop . \ ." END" cr : uselocs { aa bb -- } aa bb + aa bb - - drop ; : BLOCS ( N -- ) 0 DO i 77 uselocs LOOP ; ." START" cr 2000000 blocs ." END" cr pforth-21/siev.fs100664 1750 1750 1074 6051703776 12540 0ustar bdalebdale\ #! /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 : 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 1000 0 DO PRIMES NIP LOOP ; \ SECS BENCHMARK . SECS SWAP - CR . .( secs) : main flags 8190 + eflag ! benchmark ( . ) drop ; pforth-21/Makefile100664 1750 1750 4505 6512260610 12665 0ustar bdalebdale# @(#) rlsMakefile 97/12/10 1.1 # makefile for pForth # Portable Forth written in 'C' # Phil Burk .SUFFIXES: .c .o # Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG # See "docs/pf_ref.htm" file for more info. SOURCEDIR = csrc OBJECTDIR = objects EMBOBJECTDIR = embobjects FULL_WARNINGS = -O2 \ -fsigned-char \ -fno-builtin \ -fno-unroll-loops \ -fpeephole \ -fno-keep-inline-functions \ -x c++ \ -Wcast-qual \ -Wall \ -Wwrite-strings \ -Winline \ -Wmissing-prototypes \ -Wmissing-declarations CCOPTS = -DPF_SUPPORT_FP $(FULL_WARNINGS) COMPILER = gcc EMBCCOPTS = -DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \ -DPF_NO_CLIB -DPF_STATIC_DIC ####################################### # Build file lists from wildcards. PFITEMP = ${wildcard ${SOURCEDIR}/*.h} PFINCLUDES = ${PFITEMP:${SOURCEDIR}/pfdicdat.h=} PFSOURCE = ${wildcard ${SOURCEDIR}/*.c} PFTEMP = ${PFSOURCE:%.c=%.o} PFOBJS = ${PFTEMP:${SOURCEDIR}/%=${OBJECTDIR}/%} PFEMBOBJS = ${PFTEMP:${SOURCEDIR}/%=${EMBOBJECTDIR}/%} COMPILE = $(COMPILER) $(CCOPTS) $(CDEFS) ${OBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c $(COMPILE) -O -o ${OBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c ${EMBOBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c ${SOURCEDIR}/pfdicdat.h $(COMPILE) -O -o ${EMBOBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c $(EMBCCOPTS) all: pforth pforth.dic pffiles: echo "ITEMP FILES -----------------" echo ${PFITEMP} echo "INCLUDE FILES -----------------" echo ${PFINCLUDES} echo "'C' FILES ---------------------" echo ${PFSOURCE} echo "OBJECT FILES ------------------" echo ${PFOBJS} echo "EMBEDDED OBJECT FILES ------------------" echo ${PFEMBOBJS} # build pforth by compiling 'C' source pforth: $(PFINCLUDES) $(PFOBJS) $(COMPILER) $(PFOBJS) -lm -o pforth # build basic dictionary by running newly built pforth and including system.fth pforth.dic: pforth pforth -i system.fth ${SOURCEDIR}/pfdicdat.h: pforth pforth.dic @(echo 'INCLUDE utils/savedicd.fth'; \ echo 'SDAD'; \ echo 'bye') | \ pforth -dpforth.dic cp pfdicdat.h ${SOURCEDIR} pfemb: $(PFINCLUDES) $(PFEMBOBJS) $(COMPILER) $(PFEMBOBJS) -lm -o pfemb clean: rm -f $(PFOBJS) $(PFEMBOBJS) pforth *.dic core ${SOURCEDIR}/pfdicdat.h pfemb pforth-21/t_floats.fth100664 1750 1750 7436 6567070564 13572 0ustar bdalebdale\ @(#) 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 -f- ) fover (fs.) >float fswap f~ AND ; : T_FE. ( -- ok? ) ( r -f- ) fover (fe.) >float fswap f~ AND ; : T_FG. ( -- ok? ) ( r -f- ) fover (f.) >float fswap f~ AND ; : T_F>D ( -- ok? ) ( r -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 ( -- fmust 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 pforth-21/trace.fth100664 1750 1750 27017 6512247204 13055 0ustar bdalebdale\ @(#) 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 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 30 space.to.column \ show data stack trace.show.stack 65 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 100 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 ." 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 > 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 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 1 [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] pforth-21/go.bat100664 1750 1750 50 6567334324 12267 0ustar bdalebdalebincmp -m10 pforth.dic pforth_mac.dic pforth-21/mipsBuild/ 40775 1750 1750 0 6537317354 13073 5ustar bdalebdalepforth-21/mipsBuild/pforth.bld100444 1750 1750 3045 6531417556 15152 0ustar bdalebdale#!build default: program :check=bounds :check=assignbound :check=nilderef :check=switch :check=zerodivide :check=usevariable :check=return :mips_option=littleendian :mips_cputype=r5000 :defines=PF_SUPPORT_FLOAT e:\nomad\pforth\csrc\pf_all.h include_file e:\nomad\pforth\csrc\pf_cglue.c C e:\nomad\pforth\csrc\pf_cglue.h include_file e:\nomad\pforth\csrc\pf_clib.c C e:\nomad\pforth\csrc\pf_clib.h include_file e:\nomad\pforth\csrc\pf_core.c C e:\nomad\pforth\csrc\pf_core.h include_file e:\nomad\pforth\csrc\pf_float.h include_file e:\nomad\pforth\csrc\pf_guts.h include_file e:\nomad\pforth\csrc\pf_host.h include_file e:\nomad\pforth\csrc\pf_inner.c C e:\nomad\pforth\csrc\pf_io.c C e:\nomad\pforth\csrc\pf_io.h include_file e:\nomad\pforth\csrc\pf_mac.h include_file e:\nomad\pforth\csrc\pf_main.c C e:\nomad\pforth\csrc\pf_mem.c C e:\nomad\pforth\csrc\pf_mem.h include_file e:\nomad\pforth\csrc\pf_save.c C e:\nomad\pforth\csrc\pf_save.h include_file e:\nomad\pforth\csrc\pf_text.c C :c_option=needprototype :c_mode=ansi e:\nomad\pforth\csrc\pf_text.h include_file e:\nomad\pforth\csrc\pf_types.h include_file e:\nomad\pforth\csrc\pf_unix.h include_file e:\nomad\pforth\csrc\pf_win32.h include_file e:\nomad\pforth\csrc\pf_words.c C e:\nomad\pforth\csrc\pf_words.h include_file e:\nomad\pforth\csrc\pfcompfp.h include_file e:\nomad\pforth\csrc\pfcompil.c C e:\nomad\pforth\csrc\pfcompil.h include_file e:\nomad\pforth\csrc\pfcustom.c C e:\nomad\pforth\csrc\pfinnrfp.h include_file e:\nomad\pforth\csrc\pforth.h include_file pforth-21/checkit.fth100664 1750 1750 631 6567344462 13340 0ustar bdalebdale\ compare dictionaries anew comp hex : checksum { start end -- sum } 0 end start DO i @ + 4 +LOOP ; : findword { target start end -- } end start DO i @ target = IF ." found at " i u. cr i 16 dump THEN 4 +LOOP ; echo on hex $ 01500fc4 codebase here findword codebase here cr .s checksum u. cr namebase context @ cr .s checksum u. cr decimal echo off