[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
	gVarQuiet = 0;        /* Suppress unnecessary messages, OK, etc. */\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)  ((uint8_t *)((((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 = ( uint8_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( 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 = NULL;\r
	}\r
\r
/* Allocate memory for code. */\r
	dic->dic_CodeBaseUnaligned = ( uint8_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( dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);\r
\r
	dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;\r
	dic->dic_CodePtr.Byte = 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( !pfQueryQuiet() )\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
		EMIT_CR;\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
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
	95	gVarQuiet = 0; /* Suppress unnecessary messages, OK, etc. */\r
	96	gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */\r
	97	gIncludeIndex = 0;\r
	98	\r
	99	/* non-zero */\r
	100	gVarBase = 10; /* Numeric Base. */\r
	101	gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
	102	gVarTraceStack = 1; \r
	103	\r
	104	pfInitMemoryAllocator();\r
	105	ioInit();\r
	106	}\r
	107	static void pfTerm( void )\r
	108	{\r
	109	ioTerm();\r
	110	}\r
	111	\r
	112	/***************************************************************\r
	113	** Task Management\r
	114	***************************************************************/\r
	115	\r
	116	void pfDeleteTask( PForthTask task )\r
	117	{\r
	118	pfTaskData_t cftd = (pfTaskData_t )task;\r
	119	FREE_VAR( cftd->td_ReturnLimit );\r
	120	FREE_VAR( cftd->td_StackLimit );\r
	121	pfFreeMem( cftd );\r
	122	}\r
	123	\r
	124	/* Allocate some extra cells to protect against mild stack underflows. */\r
	125	#define STACK_SAFETY (8)\r
1cb310e6	126	PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )\r
bb6b2dcd	127	{\r
	128	pfTaskData_t *cftd;\r
	129	\r
	130	cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );\r
	131	if( !cftd ) goto nomem;\r
	132	pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));\r
	133	\r
	134	/* Allocate User Stack */\r
1cb310e6	135	cftd->td_StackLimit = (cell_t ) pfAllocMem((ucell_t)(sizeof(cell_t) \r
bb6b2dcd	136	(UserStackDepth + STACK_SAFETY)));\r
	137	if( !cftd->td_StackLimit ) goto nomem;\r
	138	cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;\r
	139	cftd->td_StackPtr = cftd->td_StackBase;\r
	140	\r
	141	/* Allocate Return Stack */\r
1cb310e6	142	cftd->td_ReturnLimit = (cell_t ) pfAllocMem((ucell_t)(sizeof(cell_t) ReturnStackDepth) );\r
bb6b2dcd	143	if( !cftd->td_ReturnLimit ) goto nomem;\r
	144	cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;\r
	145	cftd->td_ReturnPtr = cftd->td_ReturnBase;\r
	146	\r
	147	/* Allocate Float Stack */\r
	148	#ifdef PF_SUPPORT_FP\r
	149	/* Allocate room for as many Floats as we do regular data. */\r
1cb310e6	150	cftd->td_FloatStackLimit = (PF_FLOAT ) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) \r
bb6b2dcd	151	(UserStackDepth + STACK_SAFETY)));\r
	152	if( !cftd->td_FloatStackLimit ) goto nomem;\r
	153	cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;\r
	154	cftd->td_FloatStackPtr = cftd->td_FloatStackBase;\r
	155	#endif\r
	156	\r
	157	cftd->td_InputStream = PF_STDIN;\r
	158	\r
	159	cftd->td_SourcePtr = &cftd->td_TIB[0];\r
	160	cftd->td_SourceNum = 0;\r
	161	\r
	162	return (PForthTask) cftd;\r
	163	\r
	164	nomem:\r
	165	ERR("CreateTaskContext: insufficient memory.\n");\r
	166	if( cftd ) pfDeleteTask( (PForthTask) cftd );\r
	167	return NULL;\r
	168	}\r
	169	\r
	170	/***************************************************************\r
	171	** Dictionary Management\r
	172	***************************************************************/\r
	173	\r
1cb310e6	174	cell_t pfExecIfDefined( const char *CString )\r
bb6b2dcd	175	{\r
bb6b2dcd	176	int result = 0;\r
b3ad2602	177	if( NAME_BASE != (cell_t)NULL)\r
bb6b2dcd	178	{\r
	179	ExecToken XT;\r
	180	if( ffFindC( CString, &XT ) )\r
	181	{\r
	182	result = pfCatch( XT );\r
	183	}\r
	184	}\r
	185	return result;\r
	186	}\r
	187	\r
	188	/***************************************************************\r
	189	** Delete a dictionary created by pfCreateDictionary()\r
	190	*/\r
	191	void pfDeleteDictionary( PForthDictionary dictionary )\r
	192	{\r
	193	pfDictionary_t dic = (pfDictionary_t ) dictionary;\r
	194	if( !dic ) return;\r
	195	\r
	196	if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )\r
	197	{\r
	198	FREE_VAR( dic->dic_HeaderBaseUnaligned );\r
	199	FREE_VAR( dic->dic_CodeBaseUnaligned );\r
	200	}\r
	201	pfFreeMem( dic );\r
	202	}\r
	203	\r
	204	/***************************************************************\r
	205	** Create a complete dictionary.\r
	206	** The dictionary consists of two parts, the header with the names,\r
	207	** and the code portion.\r
	208	** Delete using pfDeleteDictionary().\r
	209	** Return pointer to dictionary management structure.\r
	210	*/\r
1cb310e6	211	PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )\r
bb6b2dcd	212	{\r
	213	/* Allocate memory for initial dictionary. */\r
	214	pfDictionary_t *dic;\r
	215	\r
	216	dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );\r
	217	if( !dic ) goto nomem;\r
	218	pfSetMemory( dic, 0, sizeof( pfDictionary_t ));\r
	219	\r
	220	dic->dic_Flags \|= PF_DICF_ALLOCATED_SEGMENTS;\r
	221	\r
	222	/* Align dictionary segments to preserve alignment of floats across hosts.\r
	223	* Thank you Helmut Proelss for pointing out that this needs to be cast\r
1cb310e6	224	* to (ucell_t) on 16 bit systems.\r
bb6b2dcd	225	*/\r
1cb310e6	226	#define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))\r
1cb310e6	227	#define DIC_ALIGN(addr) ((uint8_t *)((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)))\r
bb6b2dcd	228	\r
	229	/* Allocate memory for header. */\r
	230	if( HeaderSize > 0 )\r
	231	{\r
1cb310e6	232	dic->dic_HeaderBaseUnaligned = ( uint8_t * ) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );\r
bb6b2dcd	233	if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
	234	/* Align header base. */\r
	235	dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);\r
1cb310e6	236	pfSetMemory( dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);\r
bb6b2dcd	237	dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;\r
b3ad2602	238	dic->dic_HeaderPtr = dic->dic_HeaderBase;\r
bb6b2dcd	239	}\r
	240	else\r
	241	{\r
	242	dic->dic_HeaderBase = NULL;\r
	243	}\r
	244	\r
	245	/* Allocate memory for code. */\r
1cb310e6	246	dic->dic_CodeBaseUnaligned = ( uint8_t * ) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );\r
bb6b2dcd	247	if( !dic->dic_CodeBaseUnaligned ) goto nomem;\r
bb6b2dcd	248	dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);\r
1cb310e6	249	pfSetMemory( dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);\r
bb6b2dcd	250	\r
	251	dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;\r
	252	dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES); \r
	253	\r
	254	return (PForthDictionary) dic;\r
	255	nomem:\r
	256	pfDeleteDictionary( dic );\r
	257	return NULL;\r
	258	}\r
	259	\r
	260	/***************************************************************\r
	261	** Used by Quit and other routines to restore system.\r
	262	***************************************************************/\r
	263	\r
	264	static void pfResetForthTask( void )\r
	265	{\r
	266	/* Go back to terminal input. */\r
	267	gCurrentTask->td_InputStream = PF_STDIN;\r
	268	\r
	269	/* Reset stacks. */\r
	270	gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;\r
	271	gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;\r
	272	#ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */\r
	273	gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;\r
	274	#endif\r
	275	\r
	276	/* Advance >IN to end of input. */\r
	277	gCurrentTask->td_IN = gCurrentTask->td_SourceNum;\r
	278	gVarState = 0;\r
	279	}\r
	280	\r
	281	/***************************************************************\r
	282	** Set current task context.\r
	283	***************************************************************/\r
	284	\r
	285	void pfSetCurrentTask( PForthTask task )\r
	286	{ \r
	287	gCurrentTask = (pfTaskData_t *) task;\r
	288	}\r
	289	\r
	290	/***************************************************************\r
	291	** Set Quiet Flag.\r
	292	***************************************************************/\r
	293	\r
1cb310e6	294	void pfSetQuiet( cell_t IfQuiet )\r
bb6b2dcd	295	{ \r
1cb310e6	296	gVarQuiet = (cell_t) IfQuiet;\r
bb6b2dcd	297	}\r
	298	\r
	299	/***************************************************************\r
	300	** Query message status.\r
	301	***************************************************************/\r
	302	\r
1cb310e6	303	cell_t pfQueryQuiet( void )\r
bb6b2dcd	304	{ \r
	305	return gVarQuiet;\r
	306	}\r
	307	\r
	308	/***************************************************************\r
	309	** Top level interpreter.\r
	310	***************************************************************/\r
	311	ThrowCode pfQuit( void )\r
	312	{\r
	313	ThrowCode exception;\r
	314	int go = 1;\r
	315	\r
	316	while(go)\r
	317	{\r
	318	exception = ffOuterInterpreterLoop();\r
	319	if( exception == 0 )\r
	320	{\r
	321	exception = ffOK();\r
	322	}\r
	323	\r
	324	switch( exception )\r
	325	{\r
	326	case 0:\r
	327	break;\r
	328	\r
	329	case THROW_BYE:\r
	330	go = 0;\r
	331	break;\r
	332	\r
	333	case THROW_ABORT:\r
	334	default:\r
	335	ffDotS();\r
	336	pfReportThrow( exception );\r
	337	pfHandleIncludeError();\r
	338	pfResetForthTask();\r
	339	break;\r
	340	}\r
	341	}\r
	342	\r
	343	return gVarReturnCode;\r
	344	}\r
	345	\r
	346	/***************************************************************\r
	347	** Include file based on 'C' name.\r
	348	***************************************************************/\r
	349	\r
1cb310e6	350	cell_t pfIncludeFile( const char *FileName )\r
bb6b2dcd	351	{\r
bb6b2dcd	352	FileStream *fid;\r
1cb310e6	353	cell_t Result;\r
bb6b2dcd	354	char buffer[32];\r
1cb310e6	355	cell_t numChars, len;\r
bb6b2dcd	356	\r
	357	/* Open file. */\r
	358	fid = sdOpenFile( FileName, "r" );\r
	359	if( fid == NULL )\r
	360	{\r
	361	ERR("pfIncludeFile could not open ");\r
	362	ERR(FileName);\r
	363	EMIT_CR;\r
	364	return -1;\r
	365	}\r
	366	\r
	367	/* Create a dictionary word named ::::FileName for FILE? */\r
	368	pfCopyMemory( &buffer[0], "::::", 4);\r
1cb310e6	369	len = (cell_t) pfCStringLength(FileName);\r
bb6b2dcd	370	numChars = ( len > (32-4-1) ) ? (32-4-1) : len;\r
	371	pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );\r
	372	CreateDicEntryC( ID_NOOP, buffer, 0 );\r
	373	\r
90975d26	374	Result = ffIncludeFile( fid ); /* Also close the file. */\r
bb6b2dcd	375	\r
	376	/* Create a dictionary word named ;;;; for FILE? */\r
	377	CreateDicEntryC( ID_NOOP, ";;;;", 0 );\r
	378	\r
bb6b2dcd	379	return Result;\r
	380	}\r
	381	\r
	382	/***************************************************************\r
	383	** Output 'C' string message.\r
	384	** Use sdTerminalOut which works before initializing gCurrentTask.\r
	385	***************************************************************/\r
	386	void pfDebugMessage( const char *CString )\r
	387	{\r
	388	#if 0\r
	389	while( *CString )\r
	390	{\r
	391	char c = *CString++;\r
	392	if( c == '\n' )\r
	393	{\r
	394	sdTerminalOut( 0x0D );\r
	395	sdTerminalOut( 0x0A );\r
	396	pfDebugMessage( "DBG: " );\r
	397	}\r
	398	else\r
	399	{\r
	400	sdTerminalOut( c );\r
	401	}\r
	402	}\r
	403	#else\r
	404	(void)CString;\r
	405	#endif\r
	406	}\r
	407	\r
	408	/***************************************************************\r
	409	** Print a decimal number to debug output.\r
	410	*/\r
	411	void pfDebugPrintDecimalNumber( int n )\r
	412	{\r
	413	pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );\r
	414	}\r
	415	\r
	416	\r
	417	/***************************************************************\r
	418	** Output 'C' string message.\r
	419	** This is provided to help avoid the use of printf() and other I/O\r
	420	** which may not be present on a small embedded system.\r
	421	** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.\r
	422	***************************************************************/\r
	423	void pfMessage( const char *CString )\r
	424	{\r
1cb310e6	425	ioType( CString, (cell_t) pfCStringLength(CString) );\r
bb6b2dcd	426	}\r
	427	\r
	428	/**************************************************************************\r
1cb310e6	429	** Main entry point for pForth.\r
bb6b2dcd	430	*/\r
1cb310e6	431	cell_t pfDoForth( const char DicFileName, const char SourceName, cell_t IfInit )\r
bb6b2dcd	432	{\r
	433	pfTaskData_t *cftd;\r
	434	pfDictionary_t *dic = NULL;\r
1cb310e6	435	cell_t Result = 0;\r
bb6b2dcd	436	ExecToken EntryPoint = 0;\r
bb6b2dcd	437	\r
	438	#ifdef PF_USER_INIT\r
	439	Result = PF_USER_INIT;\r
b3651f38	440	if( Result < 0 ) goto error1;\r
bb6b2dcd	441	#endif\r
	442	\r
	443	pfInit();\r
	444	\r
bb6b2dcd	445	/* Allocate Task structure. */\r
	446	pfDebugMessage("pfDoForth: call pfCreateTask()\n");\r
	447	cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );\r
	448	\r
	449	if( cftd )\r
	450	{\r
	451	pfSetCurrentTask( cftd );\r
	452	\r
	453	if( !pfQueryQuiet() )\r
	454	{\r
	455	MSG( "PForth V"PFORTH_VERSION );\r
6b91cb54	456	if( IsHostLittleEndian() ) MSG("-LE");\r
6b91cb54	457	else MSG("-BE");\r
bb6b2dcd	458	#if PF_BIG_ENDIAN_DIC\r
	459	MSG("/BE");\r
	460	#elif PF_LITTLE_ENDIAN_DIC\r
	461	MSG("/LE");\r
	462	#endif\r
1cb310e6	463	if (sizeof(cell_t) == 8)\r
	464	{\r
	465	MSG("/64");\r
	466	}\r
	467	else if (sizeof(cell_t) == 4)\r
	468	{\r
	469	MSG("/32");\r
	470	}\r
	471	\r
bb6b2dcd	472	MSG( ", built "__DATE__" "__TIME__ );\r
	473	}\r
	474	\r
	475	/* Don't use MSG before task set. */\r
	476	if( SourceName )\r
	477	{\r
	478	pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");\r
	479	}\r
	480	\r
	481	\r
	482	#ifdef PF_NO_GLOBAL_INIT\r
b3651f38	483	if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */\r
bb6b2dcd	484	#endif\r
	485	\r
	486	#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))\r
	487	if( IfInit )\r
	488	{\r
	489	pfDebugMessage("Build dictionary from scratch.\n");\r
	490	dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );\r
	491	}\r
	492	else\r
	493	#else\r
	494	TOUCH(IfInit);\r
	495	#endif /* !PF_NO_INIT && !PF_NO_SHELL*/\r
	496	{\r
b3651f38	497	if( DicFileName )\r
bb6b2dcd	498	{\r
b3651f38	499	pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");\r
bb6b2dcd	500	EMIT_CR;\r
b3651f38	501	dic = pfLoadDictionary( DicFileName, &EntryPoint );\r
bb6b2dcd	502	}\r
	503	else\r
	504	{\r
	505	MSG(" (static)");\r
	506	EMIT_CR;\r
	507	dic = pfLoadStaticDictionary(); \r
	508	}\r
	509	}\r
b3651f38	510	if( dic == NULL ) goto error2;\r
bb6b2dcd	511	EMIT_CR;\r
	512	\r
	513	pfDebugMessage("pfDoForth: try AUTO.INIT\n");\r
	514	Result = pfExecIfDefined("AUTO.INIT");\r
	515	if( Result != 0 )\r
	516	{\r
	517	MSG("Error in AUTO.INIT");\r
b3651f38	518	goto error2;\r
bb6b2dcd	519	}\r
b3651f38	520	\r
bb6b2dcd	521	if( EntryPoint != 0 )\r
	522	{\r
	523	Result = pfCatch( EntryPoint );\r
	524	}\r
	525	#ifndef PF_NO_SHELL\r
	526	else\r
	527	{\r
	528	if( SourceName == NULL )\r
	529	{\r
	530	pfDebugMessage("pfDoForth: pfQuit\n");\r
	531	Result = pfQuit();\r
	532	}\r
	533	else\r
	534	{\r
	535	if( !gVarQuiet )\r
	536	{\r
	537	MSG("Including: ");\r
	538	MSG(SourceName);\r
	539	MSG("\n");\r
	540	}\r
	541	Result = pfIncludeFile( SourceName );\r
	542	}\r
	543	}\r
	544	#endif /* PF_NO_SHELL */\r
	545	\r
	546	/* Clean up after running Forth. */\r
	547	pfExecIfDefined("AUTO.TERM");\r
	548	pfDeleteDictionary( dic );\r
	549	pfDeleteTask( cftd );\r
	550	}\r
	551	\r
	552	pfTerm();\r
	553	\r
	554	#ifdef PF_USER_TERM\r
	555	PF_USER_TERM;\r
	556	#endif\r
	557	\r
	558	return Result;\r
	559	\r
b3651f38	560	error2:\r
bb6b2dcd	561	MSG("pfDoForth: Error occured.\n");\r
bb6b2dcd	562	pfDeleteTask( cftd );\r
b3651f38	563	// Terminate so we restore normal shell tty mode.\r
	564	pfTerm();\r
	565	\r
	566	#ifdef PF_USER_INIT\r
	567	error1:\r
	568	#endif\r
	569	\r
bb6b2dcd	570	return -1;\r
bb6b2dcd	571	}\r