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