[pforth] / csrc / pf_core.c

/* @(#) pf_core.c 98/01/28 1.5 */\r
/***************************************************************\r
** Forth based on 'C'\r
**\r
** This file has the main entry points to the pForth library.\r
**\r
** Author: Phil Burk\r
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
**\r
** The pForth software code is dedicated to the public domain,\r
** and any third party may reproduce, distribute and modify\r
** the pForth software code or any derivative works thereof\r
** without any compensation or license.  The pForth software\r
** code is provided on an "as is" basis without any warranty\r
** of any kind, including, without limitation, the implied\r
** warranties of merchantability and fitness for a particular\r
** purpose and their equivalents under the laws of any jurisdiction.\r
**\r
****************************************************************\r
** 940502 PLB Creation.\r
** 940505 PLB More macros.\r
** 940509 PLB Moved all stack handling into inner interpreter.\r
**        Added Create, Colon, Semicolon, HNumberQ, etc.\r
** 940510 PLB Got inner interpreter working with secondaries.\r
**        Added (LITERAL).   Compiles colon definitions.\r
** 940511 PLB Added conditionals, LITERAL, CREATE DOES>\r
** 940512 PLB Added DO LOOP DEFER, fixed R>\r
** 940520 PLB Added INCLUDE\r
** 940521 PLB Added NUMBER?\r
** 940930 PLB Outer Interpreter now uses deferred NUMBER?\r
** 941005 PLB Added ANSI locals, LEAVE, modularised\r
** 950320 RDG Added underflow checking for FP stack\r
** 970702 PLB Added STACK_SAFETY to FP stack size.\r
***************************************************************/\r
\r
#include "pf_all.h"\r
 \r
/***************************************************************\r
** Global Data\r
***************************************************************/\r
\r
char          gScratch[TIB_SIZE];\r
pfTaskData_t   *gCurrentTask = NULL;\r
pfDictionary_t *gCurrentDictionary;\r
cell_t         gNumPrimitives;\r
\r
ExecToken     gLocalCompiler_XT;   /* custom compiler for local variables */\r
ExecToken     gNumberQ_XT;         /* XT of NUMBER? */\r
ExecToken     gQuitP_XT;           /* XT of (QUIT) */\r
ExecToken     gAcceptP_XT;         /* XT of ACCEPT */\r
\r
/* Depth of data stack when colon called. */\r
cell_t         gDepthAtColon;\r
\r
/* Global Forth variables. */\r
cell_t          gVarContext;      /* Points to last name field. */\r
cell_t          gVarState;        /* 1 if compiling. */\r
cell_t          gVarBase;         /* Numeric Base. */\r
cell_t          gVarEcho;	        /* Echo input. */\r
cell_t          gVarTraceLevel;   /* Trace Level for Inner Interpreter. */\r
cell_t          gVarTraceStack;   /* Dump Stack each time if true. */\r
cell_t          gVarTraceFlags;   /* Enable various internal debug messages. */\r
cell_t          gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */\r
cell_t          gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */\r
\r
/* data for INCLUDE that allows multiple nested files. */\r
IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];\r
cell_t         gIncludeIndex;\r
\r
static void pfResetForthTask( void );\r
static void pfInit( void );\r
static void pfTerm( void );\r
\r
/* TODO move to pf_config.h header. */\r
#define DEFAULT_RETURN_DEPTH (512)\r
#define DEFAULT_USER_DEPTH (512)\r
#define DEFAULT_HEADER_SIZE (120000)\r
#define DEFAULT_CODE_SIZE (300000)\r
\r
/* Initialize globals in a function to simplify loading on\r
 * embedded systems which may not support initialization of data section.\r
 */\r
static void pfInit( void )\r
{\r
/* all zero */\r
	gCurrentTask = NULL;\r
	gCurrentDictionary = NULL;\r
	gNumPrimitives = 0;\r
	gLocalCompiler_XT = 0;\r
	gVarContext = (cell_t)NULL;   /* Points to last name field. */\r
	gVarState = 0;        /* 1 if compiling. */\r
	gVarEcho = 0;	    /* Echo input. */\r
	gVarTraceLevel = 0;   /* Trace Level for Inner Interpreter. */\r
	gVarTraceFlags = 0;   /* Enable various internal debug messages. */\r
	gVarReturnCode = 0;   /* Returned to caller of Forth, eg. UNIX shell. */\r
	gIncludeIndex = 0;\r
	\r
/* non-zero */\r
	gVarBase = 10;        /* Numeric Base. */\r
	gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
	gVarTraceStack = 1;\r
	\r
	pfInitMemoryAllocator();\r
	ioInit();\r
}\r
static void pfTerm( void )\r
{\r
	ioTerm();\r
}\r
\r
/***************************************************************\r
** Task Management\r
***************************************************************/\r
\r
void pfDeleteTask( PForthTask task )\r
{\r
	pfTaskData_t *cftd = (pfTaskData_t *)task;\r
	FREE_VAR( cftd->td_ReturnLimit );\r
	FREE_VAR( cftd->td_StackLimit );\r
	pfFreeMem( cftd );\r
}\r
\r
/* Allocate some extra cells to protect against mild stack underflows. */\r
#define STACK_SAFETY  (8)\r
PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )\r
{\r
	pfTaskData_t *cftd;\r
\r
	cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );\r
	if( !cftd ) goto nomem;\r
	pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));\r
\r
/* Allocate User Stack */\r
	cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *\r
				(UserStackDepth + STACK_SAFETY)));\r
	if( !cftd->td_StackLimit ) goto nomem;\r
	cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;\r
	cftd->td_StackPtr = cftd->td_StackBase;\r
\r
/* Allocate Return Stack */\r
	cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );\r
	if( !cftd->td_ReturnLimit ) goto nomem;\r
	cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;\r
	cftd->td_ReturnPtr = cftd->td_ReturnBase;\r
\r
/* Allocate Float Stack */\r
#ifdef PF_SUPPORT_FP\r
/* Allocate room for as many Floats as we do regular data. */\r
	cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *\r
				(UserStackDepth + STACK_SAFETY)));\r
	if( !cftd->td_FloatStackLimit ) goto nomem;\r
	cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;\r
	cftd->td_FloatStackPtr = cftd->td_FloatStackBase;\r
#endif\r
\r
	cftd->td_InputStream = PF_STDIN;\r
\r
	cftd->td_SourcePtr = &cftd->td_TIB[0];\r
	cftd->td_SourceNum = 0;\r
	\r
	return (PForthTask) cftd;\r
\r
nomem:\r
	ERR("CreateTaskContext: insufficient memory.\n");\r
	if( cftd ) pfDeleteTask( (PForthTask) cftd );\r
	return NULL;\r
}\r
\r
/***************************************************************\r
** Dictionary Management\r
***************************************************************/\r
\r
cell_t pfExecIfDefined( const char *CString )\r
{\r
	int result = 0;\r
	if( NAME_BASE != (cell_t)NULL)\r
	{\r
		ExecToken  XT;\r
		if( ffFindC( CString, &XT ) )\r
		{\r
			result = pfCatch( XT );\r
		}\r
	}\r
	return result;\r
}\r
\r
/***************************************************************\r
** Delete a dictionary created by pfCreateDictionary()\r
*/\r
void pfDeleteDictionary( PForthDictionary dictionary )\r
{\r
	pfDictionary_t *dic = (pfDictionary_t *) dictionary;\r
	if( !dic ) return;\r
	\r
	if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )\r
	{\r
		FREE_VAR( dic->dic_HeaderBaseUnaligned );\r
		FREE_VAR( dic->dic_CodeBaseUnaligned );\r
	}\r
	pfFreeMem( dic );\r
}\r
\r
/***************************************************************\r
** Create a complete dictionary.\r
** The dictionary consists of two parts, the header with the names,\r
** and the code portion.\r
** Delete using pfDeleteDictionary().\r
** Return pointer to dictionary management structure.\r
*/\r
PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )\r
{\r
/* Allocate memory for initial dictionary. */\r
	pfDictionary_t *dic;\r
\r
	dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );\r
	if( !dic ) goto nomem;\r
	pfSetMemory( dic, 0, sizeof( pfDictionary_t ));\r
\r
	dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;\r
\r
/* Align dictionary segments to preserve alignment of floats across hosts.\r
 * Thank you Helmut Proelss for pointing out that this needs to be cast\r
 * to (ucell_t) on 16 bit systems.\r
 */\r
#define DIC_ALIGNMENT_SIZE  ((ucell_t)(0x10))\r
#define DIC_ALIGN(addr)  ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))\r
\r
/* Allocate memory for header. */\r
	if( HeaderSize > 0 )\r
	{\r
		dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );\r
		if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
/* Align header base. */\r
		dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);\r
		pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);\r
		dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;\r
		dic->dic_HeaderPtr = dic->dic_HeaderBase;\r
	}\r
	else\r
	{\r
		dic->dic_HeaderBase = 0;\r
	}\r
\r
/* Allocate memory for code. */\r
	dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );\r
	if( !dic->dic_CodeBaseUnaligned ) goto nomem;\r
	dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);\r
	pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);\r
\r
	dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;\r
	dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES))); \r
	\r
	return (PForthDictionary) dic;\r
nomem:\r
	pfDeleteDictionary( dic );\r
	return NULL;\r
}\r
\r
/***************************************************************\r
** Used by Quit and other routines to restore system.\r
***************************************************************/\r
\r
static void pfResetForthTask( void )\r
{\r
/* Go back to terminal input. */\r
	gCurrentTask->td_InputStream = PF_STDIN;\r
	\r
/* Reset stacks. */\r
	gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;\r
	gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;\r
#ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */\r
	gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;\r
#endif\r
\r
/* Advance >IN to end of input. */\r
	gCurrentTask->td_IN = gCurrentTask->td_SourceNum;\r
	gVarState = 0;\r
}\r
\r
/***************************************************************\r
** Set current task context.\r
***************************************************************/\r
\r
void pfSetCurrentTask( PForthTask task )\r
{	\r
	gCurrentTask = (pfTaskData_t *) task;\r
}\r
\r
/***************************************************************\r
** Set Quiet Flag.\r
***************************************************************/\r
\r
void pfSetQuiet( cell_t IfQuiet )\r
{	\r
	gVarQuiet = (cell_t) IfQuiet;\r
}\r
\r
/***************************************************************\r
** Query message status.\r
***************************************************************/\r
\r
cell_t  pfQueryQuiet( void )\r
{	\r
	return gVarQuiet;\r
}\r
\r
/***************************************************************\r
** Top level interpreter.\r
***************************************************************/\r
ThrowCode pfQuit( void )\r
{\r
	ThrowCode exception;\r
	int go = 1;\r
	\r
	while(go)\r
	{\r
		exception = ffOuterInterpreterLoop();\r
		if( exception == 0 )\r
		{\r
			exception = ffOK();\r
		}\r
\r
		switch( exception )\r
		{\r
		case 0:\r
			break;\r
\r
		case THROW_BYE:\r
			go = 0;\r
			break;\r
\r
		case THROW_ABORT:\r
		default:\r
			ffDotS();\r
			pfReportThrow( exception );\r
			pfHandleIncludeError();\r
			pfResetForthTask();\r
			break;\r
		}\r
	}\r
\r
	return gVarReturnCode;\r
}\r
\r
/***************************************************************\r
** Include file based on 'C' name.\r
***************************************************************/\r
\r
cell_t pfIncludeFile( const char *FileName )\r
{\r
	FileStream *fid;\r
	cell_t Result;\r
	char  buffer[32];\r
	cell_t numChars, len;\r
	\r
/* Open file. */\r
	fid = sdOpenFile( FileName, "r" );\r
	if( fid == NULL )\r
	{\r
		ERR("pfIncludeFile could not open ");\r
		ERR(FileName);\r
		EMIT_CR;\r
		return -1;\r
	}\r
	\r
/* Create a dictionary word named ::::FileName for FILE? */\r
	pfCopyMemory( &buffer[0], "::::", 4);\r
	len = (cell_t) pfCStringLength(FileName);\r
	numChars = ( len > (32-4-1) ) ? (32-4-1) : len;\r
	pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );\r
	CreateDicEntryC( ID_NOOP, buffer, 0 );\r
	\r
	Result = ffIncludeFile( fid ); /* Also close the file. */\r
	\r
/* Create a dictionary word named ;;;; for FILE? */\r
	CreateDicEntryC( ID_NOOP, ";;;;", 0 );\r
	\r
	return Result;\r
}\r
\r
/***************************************************************\r
** Output 'C' string message.\r
** Use sdTerminalOut which works before initializing gCurrentTask.\r
***************************************************************/\r
void pfDebugMessage( const char *CString )\r
{\r
#if 0\r
	while( *CString )\r
	{\r
		char c = *CString++;\r
		if( c == '\n' )\r
		{\r
			sdTerminalOut( 0x0D );\r
			sdTerminalOut( 0x0A );\r
			pfDebugMessage( "DBG: " );\r
		}\r
		else\r
		{\r
			sdTerminalOut( c );\r
		}\r
	}\r
#else\r
	(void)CString;\r
#endif\r
}\r
\r
/***************************************************************\r
** Print a decimal number to debug output.\r
*/\r
void pfDebugPrintDecimalNumber( int n )\r
{\r
	pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );\r
}\r
\r
\r
/***************************************************************\r
** Output 'C' string message.\r
** This is provided to help avoid the use of printf() and other I/O\r
** which may not be present on a small embedded system.\r
** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.\r
***************************************************************/\r
void pfMessage( const char *CString )\r
{\r
	ioType( CString, (cell_t) pfCStringLength(CString) );\r
}\r
\r
/**************************************************************************\r
** Main entry point for pForth.\r
*/\r
cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )\r
{\r
	pfTaskData_t *cftd;\r
	pfDictionary_t *dic = NULL;\r
	cell_t Result = 0;\r
	ExecToken  EntryPoint = 0;\r
\r
#ifdef PF_USER_INIT\r
	Result = PF_USER_INIT;\r
	if( Result < 0 ) goto error1;\r
#endif\r
\r
	pfInit();\r
	\r
/* Allocate Task structure. */\r
	pfDebugMessage("pfDoForth: call pfCreateTask()\n");\r
	cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );\r
\r
	if( cftd )\r
	{\r
		pfSetCurrentTask( cftd );\r
		\r
		if( !gVarQuiet )\r
		{\r
			MSG( "PForth V"PFORTH_VERSION );\r
			if( IsHostLittleEndian() ) MSG("-LE");\r
			else MSG("-BE");\r
#if PF_BIG_ENDIAN_DIC\r
            MSG("/BE");\r
#elif PF_LITTLE_ENDIAN_DIC\r
            MSG("/LE");\r
#endif\r
			if (sizeof(cell_t) == 8)\r
			{\r
				MSG("/64");\r
			}\r
			else if (sizeof(cell_t) == 4)\r
			{\r
				MSG("/32");\r
			}\r
			\r
			MSG( ", built "__DATE__" "__TIME__ );\r
		}\r
\r
/* Don't use MSG before task set. */\r
		if( SourceName )\r
		{\r
			pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");\r
		}\r
\r
\r
#ifdef PF_NO_GLOBAL_INIT\r
		if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */\r
#endif\r
\r
#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
		if( IfInit )\r
		{\r
			pfDebugMessage("Build dictionary from scratch.\n");\r
			dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );\r
		}\r
		else\r
#else\r
		TOUCH(IfInit);\r
#endif /* !PF_NO_INIT && !PF_NO_SHELL*/\r
		{\r
			if( DicFileName )\r
			{\r
				pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");\r
				if( !gVarQuiet )\r
				{\r
					EMIT_CR;\r
				}\r
				dic = pfLoadDictionary( DicFileName, &EntryPoint );\r
			}\r
			else\r
			{\r
				if( !gVarQuiet )\r
				{\r
					MSG(" (static)");\r
					EMIT_CR;\r
				}\r
				dic = pfLoadStaticDictionary();			\r
			}\r
		}\r
		if( dic == NULL ) goto error2;\r
		\r
		if( !gVarQuiet )\r
		{\r
			EMIT_CR;\r
		}\r
		\r
		pfDebugMessage("pfDoForth: try AUTO.INIT\n");\r
		Result = pfExecIfDefined("AUTO.INIT");\r
		if( Result != 0 )\r
		{\r
			MSG("Error in AUTO.INIT");\r
			goto error2;\r
		}\r
 \r
		if( EntryPoint != 0 )\r
		{\r
			Result = pfCatch( EntryPoint );\r
		}\r
#ifndef PF_NO_SHELL\r
		else\r
		{\r
			if( SourceName == NULL )\r
			{\r
				pfDebugMessage("pfDoForth: pfQuit\n");\r
				Result = pfQuit();\r
			}\r
			else\r
			{\r
				if( !gVarQuiet )\r
				{\r
					MSG("Including: ");\r
					MSG(SourceName);\r
					MSG("\n");\r
				}\r
				Result = pfIncludeFile( SourceName );\r
			}\r
		}\r
#endif /* PF_NO_SHELL */\r
\r
	/* Clean up after running Forth. */\r
		pfExecIfDefined("AUTO.TERM");\r
		pfDeleteDictionary( dic );\r
		pfDeleteTask( cftd );\r
	}\r
		\r
	pfTerm();\r
\r
#ifdef PF_USER_TERM\r
	PF_USER_TERM;\r
#endif\r
	\r
	return Result;\r
	\r
error2:\r
	MSG("pfDoForth: Error occured.\n");\r
	pfDeleteTask( cftd );\r
	/* Terminate so we restore normal shell tty mode. */\r
	pfTerm();\r
\r
#ifdef PF_USER_INIT\r
error1:\r
#endif\r
\r
	return -1;\r
}\r
\r
\r
#ifdef PF_UNIT_TEST\r
cell_t pfUnitTest( void )\r
{\r
	cell_t numErrors = 0;\r
	numErrors += pfUnitTestText();\r
	return numErrors;\r
}\r
#endif\r
Commit	Line	Data
bb6b2dcd	1	/* @(#) pf_core.c 98/01/28 1.5 */\r
	2	/***************************************************************\r
	3	** Forth based on 'C'\r
	4	**\r
	5	** This file has the main entry points to the pForth library.\r
	6	**\r
	7	** Author: Phil Burk\r
	8	** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom\r
	9	**\r
	10	** The pForth software code is dedicated to the public domain,\r
	11	** and any third party may reproduce, distribute and modify\r
	12	** the pForth software code or any derivative works thereof\r
	13	** without any compensation or license. The pForth software\r
	14	** code is provided on an "as is" basis without any warranty\r
	15	** of any kind, including, without limitation, the implied\r
	16	** warranties of merchantability and fitness for a particular\r
	17	** purpose and their equivalents under the laws of any jurisdiction.\r
	18	**\r
	19	****************************************************************\r
	20	** 940502 PLB Creation.\r
	21	** 940505 PLB More macros.\r
	22	** 940509 PLB Moved all stack handling into inner interpreter.\r
	23	** Added Create, Colon, Semicolon, HNumberQ, etc.\r
	24	** 940510 PLB Got inner interpreter working with secondaries.\r
	25	** Added (LITERAL). Compiles colon definitions.\r
	26	** 940511 PLB Added conditionals, LITERAL, CREATE DOES>\r
	27	** 940512 PLB Added DO LOOP DEFER, fixed R>\r
	28	** 940520 PLB Added INCLUDE\r
	29	** 940521 PLB Added NUMBER?\r
	30	** 940930 PLB Outer Interpreter now uses deferred NUMBER?\r
	31	** 941005 PLB Added ANSI locals, LEAVE, modularised\r
	32	** 950320 RDG Added underflow checking for FP stack\r
	33	** 970702 PLB Added STACK_SAFETY to FP stack size.\r
	34	***************************************************************/\r
	35	\r
	36	#include "pf_all.h"\r
	37	\r
	38	/***************************************************************\r
	39	** Global Data\r
	40	***************************************************************/\r
	41	\r
	42	char gScratch[TIB_SIZE];\r
	43	pfTaskData_t *gCurrentTask = NULL;\r
	44	pfDictionary_t *gCurrentDictionary;\r
1cb310e6	45	cell_t gNumPrimitives;\r
bb6b2dcd	46	\r
	47	ExecToken gLocalCompiler_XT; /* custom compiler for local variables */\r
	48	ExecToken gNumberQ_XT; /* XT of NUMBER? */\r
	49	ExecToken gQuitP_XT; /* XT of (QUIT) */\r
	50	ExecToken gAcceptP_XT; /* XT of ACCEPT */\r
	51	\r
	52	/* Depth of data stack when colon called. */\r
1cb310e6	53	cell_t gDepthAtColon;\r
bb6b2dcd	54	\r
bb6b2dcd	55	/* Global Forth variables. */\r
b3ad2602	56	cell_t gVarContext; /* Points to last name field. */\r
1cb310e6	57	cell_t gVarState; /* 1 if compiling. */\r
	58	cell_t gVarBase; /* Numeric Base. */\r
	59	cell_t gVarEcho; /* Echo input. */\r
	60	cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */\r
	61	cell_t gVarTraceStack; /* Dump Stack each time if true. */\r
	62	cell_t gVarTraceFlags; /* Enable various internal debug messages. */\r
	63	cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */\r
	64	cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */\r
bb6b2dcd	65	\r
	66	/* data for INCLUDE that allows multiple nested files. */\r
	67	IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];\r
1cb310e6	68	cell_t gIncludeIndex;\r
bb6b2dcd	69	\r
	70	static void pfResetForthTask( void );\r
	71	static void pfInit( void );\r
	72	static void pfTerm( void );\r
	73	\r
	74	/* TODO move to pf_config.h header. */\r
	75	#define DEFAULT_RETURN_DEPTH (512)\r
	76	#define DEFAULT_USER_DEPTH (512)\r
	77	#define DEFAULT_HEADER_SIZE (120000)\r
	78	#define DEFAULT_CODE_SIZE (300000)\r
	79	\r
	80	/* Initialize globals in a function to simplify loading on\r
	81	* embedded systems which may not support initialization of data section.\r
	82	*/\r
	83	static void pfInit( void )\r
	84	{\r
	85	/* all zero */\r
	86	gCurrentTask = NULL;\r
	87	gCurrentDictionary = NULL;\r
	88	gNumPrimitives = 0;\r
	89	gLocalCompiler_XT = 0;\r
b3ad2602	90	gVarContext = (cell_t)NULL; /* Points to last name field. */\r
bb6b2dcd	91	gVarState = 0; /* 1 if compiling. */\r
	92	gVarEcho = 0; /* Echo input. */\r
	93	gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */\r
	94	gVarTraceFlags = 0; /* Enable various internal debug messages. */\r
bb6b2dcd	95	gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */\r
	96	gIncludeIndex = 0;\r
	97	\r
	98	/* non-zero */\r
	99	gVarBase = 10; /* Numeric Base. */\r
	100	gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
a33d774e	101	gVarTraceStack = 1;\r
bb6b2dcd	102	\r
	103	pfInitMemoryAllocator();\r
	104	ioInit();\r
	105	}\r
	106	static void pfTerm( void )\r
	107	{\r
	108	ioTerm();\r
	109	}\r
	110	\r
	111	/***************************************************************\r
	112	** Task Management\r
	113	***************************************************************/\r
	114	\r
	115	void pfDeleteTask( PForthTask task )\r
	116	{\r
	117	pfTaskData_t cftd = (pfTaskData_t )task;\r
	118	FREE_VAR( cftd->td_ReturnLimit );\r
	119	FREE_VAR( cftd->td_StackLimit );\r
	120	pfFreeMem( cftd );\r
	121	}\r
	122	\r
	123	/* Allocate some extra cells to protect against mild stack underflows. */\r
	124	#define STACK_SAFETY (8)\r
1cb310e6	125	PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )\r
bb6b2dcd	126	{\r
	127	pfTaskData_t *cftd;\r
	128	\r
	129	cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );\r
	130	if( !cftd ) goto nomem;\r
	131	pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));\r
	132	\r
	133	/* Allocate User Stack */\r
1cb310e6	134	cftd->td_StackLimit = (cell_t ) pfAllocMem((ucell_t)(sizeof(cell_t) \r
bb6b2dcd	135	(UserStackDepth + STACK_SAFETY)));\r
	136	if( !cftd->td_StackLimit ) goto nomem;\r
	137	cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;\r
	138	cftd->td_StackPtr = cftd->td_StackBase;\r
	139	\r
	140	/* Allocate Return Stack */\r
1cb310e6	141	cftd->td_ReturnLimit = (cell_t ) pfAllocMem((ucell_t)(sizeof(cell_t) ReturnStackDepth) );\r
bb6b2dcd	142	if( !cftd->td_ReturnLimit ) goto nomem;\r
	143	cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;\r
	144	cftd->td_ReturnPtr = cftd->td_ReturnBase;\r
	145	\r
	146	/* Allocate Float Stack */\r
	147	#ifdef PF_SUPPORT_FP\r
	148	/* Allocate room for as many Floats as we do regular data. */\r
1cb310e6	149	cftd->td_FloatStackLimit = (PF_FLOAT ) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) \r
bb6b2dcd	150	(UserStackDepth + STACK_SAFETY)));\r
	151	if( !cftd->td_FloatStackLimit ) goto nomem;\r
	152	cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;\r
	153	cftd->td_FloatStackPtr = cftd->td_FloatStackBase;\r
	154	#endif\r
	155	\r
	156	cftd->td_InputStream = PF_STDIN;\r
	157	\r
	158	cftd->td_SourcePtr = &cftd->td_TIB[0];\r
	159	cftd->td_SourceNum = 0;\r
	160	\r
	161	return (PForthTask) cftd;\r
	162	\r
	163	nomem:\r
	164	ERR("CreateTaskContext: insufficient memory.\n");\r
	165	if( cftd ) pfDeleteTask( (PForthTask) cftd );\r
	166	return NULL;\r
	167	}\r
	168	\r
	169	/***************************************************************\r
	170	** Dictionary Management\r
	171	***************************************************************/\r
	172	\r
1cb310e6	173	cell_t pfExecIfDefined( const char *CString )\r
bb6b2dcd	174	{\r
bb6b2dcd	175	int result = 0;\r
b3ad2602	176	if( NAME_BASE != (cell_t)NULL)\r
bb6b2dcd	177	{\r
	178	ExecToken XT;\r
	179	if( ffFindC( CString, &XT ) )\r
	180	{\r
	181	result = pfCatch( XT );\r
	182	}\r
	183	}\r
	184	return result;\r
	185	}\r
	186	\r
	187	/***************************************************************\r
	188	** Delete a dictionary created by pfCreateDictionary()\r
	189	*/\r
	190	void pfDeleteDictionary( PForthDictionary dictionary )\r
	191	{\r
	192	pfDictionary_t dic = (pfDictionary_t ) dictionary;\r
	193	if( !dic ) return;\r
	194	\r
	195	if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )\r
	196	{\r
	197	FREE_VAR( dic->dic_HeaderBaseUnaligned );\r
	198	FREE_VAR( dic->dic_CodeBaseUnaligned );\r
	199	}\r
	200	pfFreeMem( dic );\r
	201	}\r
	202	\r
	203	/***************************************************************\r
	204	** Create a complete dictionary.\r
	205	** The dictionary consists of two parts, the header with the names,\r
	206	** and the code portion.\r
	207	** Delete using pfDeleteDictionary().\r
	208	** Return pointer to dictionary management structure.\r
	209	*/\r
1cb310e6	210	PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )\r
bb6b2dcd	211	{\r
	212	/* Allocate memory for initial dictionary. */\r
	213	pfDictionary_t *dic;\r
	214	\r
	215	dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );\r
	216	if( !dic ) goto nomem;\r
	217	pfSetMemory( dic, 0, sizeof( pfDictionary_t ));\r
	218	\r
	219	dic->dic_Flags \|= PF_DICF_ALLOCATED_SEGMENTS;\r
	220	\r
	221	/* Align dictionary segments to preserve alignment of floats across hosts.\r
	222	* Thank you Helmut Proelss for pointing out that this needs to be cast\r
1cb310e6	223	* to (ucell_t) on 16 bit systems.\r
bb6b2dcd	224	*/\r
1cb310e6	225	#define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))\r
a80283a7	226	#define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))\r
bb6b2dcd	227	\r
	228	/* Allocate memory for header. */\r
	229	if( HeaderSize > 0 )\r
	230	{\r
a80283a7	231	dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );\r
bb6b2dcd	232	if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
	233	/* Align header base. */\r
	234	dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);\r
a80283a7	235	pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);\r
bb6b2dcd	236	dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;\r
b3ad2602	237	dic->dic_HeaderPtr = dic->dic_HeaderBase;\r
bb6b2dcd	238	}\r
	239	else\r
	240	{\r
a80283a7	241	dic->dic_HeaderBase = 0;\r
bb6b2dcd	242	}\r
	243	\r
	244	/* Allocate memory for code. */\r
a80283a7	245	dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );\r
bb6b2dcd	246	if( !dic->dic_CodeBaseUnaligned ) goto nomem;\r
bb6b2dcd	247	dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);\r
a80283a7	248	pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);\r
bb6b2dcd	249	\r
bb6b2dcd	250	dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;\r
a80283a7	251	dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES))); \r
bb6b2dcd	252	\r
	253	return (PForthDictionary) dic;\r
	254	nomem:\r
	255	pfDeleteDictionary( dic );\r
	256	return NULL;\r
	257	}\r
	258	\r
	259	/***************************************************************\r
	260	** Used by Quit and other routines to restore system.\r
	261	***************************************************************/\r
	262	\r
	263	static void pfResetForthTask( void )\r
	264	{\r
	265	/* Go back to terminal input. */\r
	266	gCurrentTask->td_InputStream = PF_STDIN;\r
	267	\r
	268	/* Reset stacks. */\r
	269	gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;\r
	270	gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;\r
	271	#ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */\r
	272	gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;\r
	273	#endif\r
	274	\r
	275	/* Advance >IN to end of input. */\r
	276	gCurrentTask->td_IN = gCurrentTask->td_SourceNum;\r
	277	gVarState = 0;\r
	278	}\r
	279	\r
	280	/***************************************************************\r
	281	** Set current task context.\r
	282	***************************************************************/\r
	283	\r
	284	void pfSetCurrentTask( PForthTask task )\r
	285	{ \r
	286	gCurrentTask = (pfTaskData_t *) task;\r
	287	}\r
	288	\r
	289	/***************************************************************\r
	290	** Set Quiet Flag.\r
	291	***************************************************************/\r
	292	\r
1cb310e6	293	void pfSetQuiet( cell_t IfQuiet )\r
bb6b2dcd	294	{ \r
1cb310e6	295	gVarQuiet = (cell_t) IfQuiet;\r
bb6b2dcd	296	}\r
	297	\r
	298	/***************************************************************\r
	299	** Query message status.\r
	300	***************************************************************/\r
	301	\r
1cb310e6	302	cell_t pfQueryQuiet( void )\r
bb6b2dcd	303	{ \r
	304	return gVarQuiet;\r
	305	}\r
	306	\r
	307	/***************************************************************\r
	308	** Top level interpreter.\r
	309	***************************************************************/\r
	310	ThrowCode pfQuit( void )\r
	311	{\r
	312	ThrowCode exception;\r
	313	int go = 1;\r
	314	\r
	315	while(go)\r
	316	{\r
	317	exception = ffOuterInterpreterLoop();\r
	318	if( exception == 0 )\r
	319	{\r
	320	exception = ffOK();\r
	321	}\r
	322	\r
	323	switch( exception )\r
	324	{\r
	325	case 0:\r
	326	break;\r
	327	\r
	328	case THROW_BYE:\r
	329	go = 0;\r
	330	break;\r
	331	\r
	332	case THROW_ABORT:\r
	333	default:\r
	334	ffDotS();\r
	335	pfReportThrow( exception );\r
	336	pfHandleIncludeError();\r
	337	pfResetForthTask();\r
	338	break;\r
	339	}\r
	340	}\r
	341	\r
	342	return gVarReturnCode;\r
	343	}\r
	344	\r
	345	/***************************************************************\r
	346	** Include file based on 'C' name.\r
	347	***************************************************************/\r
	348	\r
1cb310e6	349	cell_t pfIncludeFile( const char *FileName )\r
bb6b2dcd	350	{\r
bb6b2dcd	351	FileStream *fid;\r
1cb310e6	352	cell_t Result;\r
bb6b2dcd	353	char buffer[32];\r
1cb310e6	354	cell_t numChars, len;\r
bb6b2dcd	355	\r
	356	/* Open file. */\r
	357	fid = sdOpenFile( FileName, "r" );\r
	358	if( fid == NULL )\r
	359	{\r
	360	ERR("pfIncludeFile could not open ");\r
	361	ERR(FileName);\r
	362	EMIT_CR;\r
	363	return -1;\r
	364	}\r
	365	\r
	366	/* Create a dictionary word named ::::FileName for FILE? */\r
	367	pfCopyMemory( &buffer[0], "::::", 4);\r
1cb310e6	368	len = (cell_t) pfCStringLength(FileName);\r
bb6b2dcd	369	numChars = ( len > (32-4-1) ) ? (32-4-1) : len;\r
	370	pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );\r
	371	CreateDicEntryC( ID_NOOP, buffer, 0 );\r
	372	\r
90975d26	373	Result = ffIncludeFile( fid ); /* Also close the file. */\r
bb6b2dcd	374	\r
	375	/* Create a dictionary word named ;;;; for FILE? */\r
	376	CreateDicEntryC( ID_NOOP, ";;;;", 0 );\r
	377	\r
bb6b2dcd	378	return Result;\r
	379	}\r
	380	\r
	381	/***************************************************************\r
	382	** Output 'C' string message.\r
	383	** Use sdTerminalOut which works before initializing gCurrentTask.\r
	384	***************************************************************/\r
	385	void pfDebugMessage( const char *CString )\r
	386	{\r
	387	#if 0\r
	388	while( *CString )\r
	389	{\r
	390	char c = *CString++;\r
	391	if( c == '\n' )\r
	392	{\r
	393	sdTerminalOut( 0x0D );\r
	394	sdTerminalOut( 0x0A );\r
	395	pfDebugMessage( "DBG: " );\r
	396	}\r
	397	else\r
	398	{\r
	399	sdTerminalOut( c );\r
	400	}\r
	401	}\r
	402	#else\r
	403	(void)CString;\r
	404	#endif\r
	405	}\r
	406	\r
	407	/***************************************************************\r
	408	** Print a decimal number to debug output.\r
	409	*/\r
	410	void pfDebugPrintDecimalNumber( int n )\r
	411	{\r
	412	pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );\r
	413	}\r
	414	\r
	415	\r
	416	/***************************************************************\r
	417	** Output 'C' string message.\r
	418	** This is provided to help avoid the use of printf() and other I/O\r
	419	** which may not be present on a small embedded system.\r
	420	** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.\r
	421	***************************************************************/\r
	422	void pfMessage( const char *CString )\r
	423	{\r
1cb310e6	424	ioType( CString, (cell_t) pfCStringLength(CString) );\r
bb6b2dcd	425	}\r
	426	\r
	427	/**************************************************************************\r
1cb310e6	428	** Main entry point for pForth.\r
bb6b2dcd	429	*/\r
1cb310e6	430	cell_t pfDoForth( const char DicFileName, const char SourceName, cell_t IfInit )\r
bb6b2dcd	431	{\r
	432	pfTaskData_t *cftd;\r
	433	pfDictionary_t *dic = NULL;\r
1cb310e6	434	cell_t Result = 0;\r
bb6b2dcd	435	ExecToken EntryPoint = 0;\r
bb6b2dcd	436	\r
	437	#ifdef PF_USER_INIT\r
	438	Result = PF_USER_INIT;\r
b3651f38	439	if( Result < 0 ) goto error1;\r
bb6b2dcd	440	#endif\r
	441	\r
	442	pfInit();\r
	443	\r
bb6b2dcd	444	/* Allocate Task structure. */\r
	445	pfDebugMessage("pfDoForth: call pfCreateTask()\n");\r
	446	cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );\r
	447	\r
	448	if( cftd )\r
	449	{\r
	450	pfSetCurrentTask( cftd );\r
	451	\r
a80283a7	452	if( !gVarQuiet )\r
bb6b2dcd	453	{\r
bb6b2dcd	454	MSG( "PForth V"PFORTH_VERSION );\r
6b91cb54	455	if( IsHostLittleEndian() ) MSG("-LE");\r
6b91cb54	456	else MSG("-BE");\r
bb6b2dcd	457	#if PF_BIG_ENDIAN_DIC\r
	458	MSG("/BE");\r
	459	#elif PF_LITTLE_ENDIAN_DIC\r
	460	MSG("/LE");\r
	461	#endif\r
1cb310e6	462	if (sizeof(cell_t) == 8)\r
	463	{\r
	464	MSG("/64");\r
	465	}\r
	466	else if (sizeof(cell_t) == 4)\r
	467	{\r
	468	MSG("/32");\r
	469	}\r
	470	\r
bb6b2dcd	471	MSG( ", built "__DATE__" "__TIME__ );\r
	472	}\r
	473	\r
	474	/* Don't use MSG before task set. */\r
	475	if( SourceName )\r
	476	{\r
	477	pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");\r
	478	}\r
	479	\r
	480	\r
	481	#ifdef PF_NO_GLOBAL_INIT\r
b3651f38	482	if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */\r
bb6b2dcd	483	#endif\r
	484	\r
	485	#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
	486	if( IfInit )\r
	487	{\r
	488	pfDebugMessage("Build dictionary from scratch.\n");\r
	489	dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );\r
	490	}\r
	491	else\r
	492	#else\r
	493	TOUCH(IfInit);\r
	494	#endif /* !PF_NO_INIT && !PF_NO_SHELL*/\r
	495	{\r
b3651f38	496	if( DicFileName )\r
bb6b2dcd	497	{\r
b3651f38	498	pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");\r
4f237935	499	if( !gVarQuiet )\r
	500	{\r
	501	EMIT_CR;\r
	502	}\r
b3651f38	503	dic = pfLoadDictionary( DicFileName, &EntryPoint );\r
bb6b2dcd	504	}\r
	505	else\r
	506	{\r
4f237935	507	if( !gVarQuiet )\r
	508	{\r
	509	MSG(" (static)");\r
	510	EMIT_CR;\r
	511	}\r
bb6b2dcd	512	dic = pfLoadStaticDictionary(); \r
	513	}\r
	514	}\r
b3651f38	515	if( dic == NULL ) goto error2;\r
a80283a7	516	\r
	517	if( !gVarQuiet )\r
	518	{\r
	519	EMIT_CR;\r
	520	}\r
	521	\r
bb6b2dcd	522	pfDebugMessage("pfDoForth: try AUTO.INIT\n");\r
	523	Result = pfExecIfDefined("AUTO.INIT");\r
	524	if( Result != 0 )\r
	525	{\r
	526	MSG("Error in AUTO.INIT");\r
b3651f38	527	goto error2;\r
bb6b2dcd	528	}\r
b3651f38	529	\r
bb6b2dcd	530	if( EntryPoint != 0 )\r
	531	{\r
	532	Result = pfCatch( EntryPoint );\r
	533	}\r
	534	#ifndef PF_NO_SHELL\r
	535	else\r
	536	{\r
	537	if( SourceName == NULL )\r
	538	{\r
	539	pfDebugMessage("pfDoForth: pfQuit\n");\r
	540	Result = pfQuit();\r
	541	}\r
	542	else\r
	543	{\r
	544	if( !gVarQuiet )\r
	545	{\r
	546	MSG("Including: ");\r
	547	MSG(SourceName);\r
	548	MSG("\n");\r
	549	}\r
	550	Result = pfIncludeFile( SourceName );\r
	551	}\r
	552	}\r
	553	#endif /* PF_NO_SHELL */\r
	554	\r
	555	/* Clean up after running Forth. */\r
	556	pfExecIfDefined("AUTO.TERM");\r
	557	pfDeleteDictionary( dic );\r
	558	pfDeleteTask( cftd );\r
	559	}\r
	560	\r
	561	pfTerm();\r
	562	\r
	563	#ifdef PF_USER_TERM\r
	564	PF_USER_TERM;\r
	565	#endif\r
	566	\r
	567	return Result;\r
	568	\r
b3651f38	569	error2:\r
bb6b2dcd	570	MSG("pfDoForth: Error occured.\n");\r
bb6b2dcd	571	pfDeleteTask( cftd );\r
a80283a7	572	/* Terminate so we restore normal shell tty mode. */\r
b3651f38	573	pfTerm();\r
	574	\r
	575	#ifdef PF_USER_INIT\r
	576	error1:\r
	577	#endif\r
	578	\r
bb6b2dcd	579	return -1;\r
bb6b2dcd	580	}\r
e2531e83	581	\r
	582	\r
	583	#ifdef PF_UNIT_TEST\r
	584	cell_t pfUnitTest( void )\r
	585	{\r
	586	cell_t numErrors = 0;\r
	587	numErrors += pfUnitTestText();\r
	588	return numErrors;\r
	589	}\r
	590	#endif\r