/* @(#) pf_core.c 98/01/28 1.5 */
/***************************************************************
** This file has the main entry points to the pForth library.
** 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.
****************************************************************
** 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.
***************************************************************/
/***************************************************************
***************************************************************/
pfTaskData_t
*gCurrentTask
= NULL
;
pfDictionary_t
*gCurrentDictionary
;
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. */
/* 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
];
static void pfResetForthTask( void );
static void pfInit( void );
static void pfTerm( void );
/* TODO move to pf_config.h header. */
#define DEFAULT_RETURN_DEPTH (512)
#define DEFAULT_USER_DEPTH (512)
#define DEFAULT_HEADER_SIZE (120000)
#define DEFAULT_CODE_SIZE (300000)
/* Initialize globals in a function to simplify loading on
* embedded systems which may not support initialization of data section.
static void pfInit( void )
gCurrentDictionary
= NULL
;
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. */
gVarBase
= 10; /* Numeric Base. */
gDepthAtColon
= DEPTH_AT_COLON_INVALID
;
static void pfTerm( void )
/***************************************************************
***************************************************************/
void pfDeleteTask( PForthTask task
)
pfTaskData_t
*cftd
= (pfTaskData_t
*)task
;
FREE_VAR( cftd
->td_ReturnLimit
);
FREE_VAR( cftd
->td_StackLimit
);
/* Allocate some extra cells to protect against mild stack underflows. */
PForthTask
pfCreateTask( cell_t UserStackDepth
, cell_t ReturnStackDepth
)
cftd
= ( pfTaskData_t
* ) pfAllocMem( sizeof( pfTaskData_t
) );
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 */
/* 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
;
cftd
->td_InputStream
= PF_STDIN
;
cftd
->td_SourcePtr
= &cftd
->td_TIB
[0];
return (PForthTask
) cftd
;
ERR("CreateTaskContext: insufficient memory.\n");
if( cftd
) pfDeleteTask( (PForthTask
) cftd
);
/***************************************************************
***************************************************************/
cell_t
pfExecIfDefined( const char *CString
)
if( NAME_BASE
!= (cell_t
)NULL
)
if( ffFindC( CString
, &XT
) )
/***************************************************************
** Delete a dictionary created by pfCreateDictionary()
void pfDeleteDictionary( PForthDictionary dictionary
)
pfDictionary_t
*dic
= (pfDictionary_t
*) dictionary
;
if( dic
->dic_Flags
& PF_DICF_ALLOCATED_SEGMENTS
)
FREE_VAR( dic
->dic_HeaderBaseUnaligned
);
FREE_VAR( dic
->dic_CodeBaseUnaligned
);
/***************************************************************
** Create a complete dictionary.
** The dictionary consists of two parts, the header with the names,
** Delete using pfDeleteDictionary().
** Return pointer to dictionary management structure.
PForthDictionary
pfCreateDictionary( cell_t HeaderSize
, cell_t CodeSize
)
/* Allocate memory for initial dictionary. */
dic
= ( pfDictionary_t
* ) pfAllocMem( sizeof( pfDictionary_t
) );
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. */
dic
->dic_HeaderBaseUnaligned
= (ucell_t
) pfAllocMem( (ucell_t
) HeaderSize
+ DIC_ALIGNMENT_SIZE
);
if( !dic
->dic_HeaderBaseUnaligned
) goto nomem
;
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
;
/* 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
;
pfDeleteDictionary( dic
);
/***************************************************************
** Used by Quit and other routines to restore system.
***************************************************************/
static void pfResetForthTask( void )
/* Go back to terminal input. */
gCurrentTask
->td_InputStream
= PF_STDIN
;
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
;
/* Advance >IN to end of input. */
gCurrentTask
->td_IN
= gCurrentTask
->td_SourceNum
;
/***************************************************************
** Set current task context.
***************************************************************/
void pfSetCurrentTask( PForthTask task
)
gCurrentTask
= (pfTaskData_t
*) task
;
/***************************************************************
***************************************************************/
void pfSetQuiet( cell_t IfQuiet
)
gVarQuiet
= (cell_t
) IfQuiet
;
/***************************************************************
***************************************************************/
cell_t
pfQueryQuiet( void )
/***************************************************************
** Top level interpreter.
***************************************************************/
exception
= ffOuterInterpreterLoop();
pfReportThrow( exception
);
/***************************************************************
** Include file based on 'C' name.
***************************************************************/
cell_t
pfIncludeFile( const char *FileName
)
fid
= sdOpenFile( FileName
, "r" );
ERR("pfIncludeFile could not open ");
/* 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 );
/***************************************************************
** Output 'C' string message.
** Use sdTerminalOut which works before initializing gCurrentTask.
***************************************************************/
void pfDebugMessage( const char *CString
)
pfDebugMessage( "DBG: " );
/***************************************************************
** Print a decimal number to debug output.
void pfDebugPrintDecimalNumber( int n
)
pfDebugMessage( ConvertNumberToText( n
, 10, TRUE
, 1 ) );
/***************************************************************
** Output 'C' string message.
** This is provided to help avoid the use of printf() and other I/O
** which may not be present on a small embedded system.
** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
***************************************************************/
void pfMessage( const char *CString
)
ioType( CString
, (cell_t
) pfCStringLength(CString
) );
/**************************************************************************
** Main entry point for pForth.
cell_t
pfDoForth( const char *DicFileName
, const char *SourceName
, cell_t IfInit
)
pfDictionary_t
*dic
= NULL
;
ExecToken EntryPoint
= 0;
if( Result
< 0 ) goto error1
;
/* Allocate Task structure. */
pfDebugMessage("pfDoForth: call pfCreateTask()\n");
cftd
= pfCreateTask( DEFAULT_USER_DEPTH
, DEFAULT_RETURN_DEPTH
);
pfSetCurrentTask( cftd
);
MSG( "PForth V"PFORTH_VERSION
);
if( IsHostLittleEndian() ) MSG("-LE");
#elif PF_LITTLE_ENDIAN_DIC
else if (sizeof(cell_t
) == 4)
MSG( ", built "__DATE__
" "__TIME__
);
/* Don't use MSG before task set. */
pfDebugMessage("SourceName = "); pfDebugMessage(SourceName
); pfDebugMessage("\n");
if( LoadCustomFunctionTable() < 0 ) goto error2
; /* Init custom 'C' call array. */
#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
pfDebugMessage("Build dictionary from scratch.\n");
dic
= pfBuildDictionary( DEFAULT_HEADER_SIZE
, DEFAULT_CODE_SIZE
);
#endif /* !PF_NO_INIT && !PF_NO_SHELL*/
pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName
); pfDebugMessage("\n");
dic
= pfLoadDictionary( DicFileName
, &EntryPoint
);
dic
= pfLoadStaticDictionary();
if( dic
== NULL
) goto error2
;
pfDebugMessage("pfDoForth: try AUTO.INIT\n");
Result
= pfExecIfDefined("AUTO.INIT");
MSG("Error in AUTO.INIT");
Result
= pfCatch( EntryPoint
);
pfDebugMessage("pfDoForth: pfQuit\n");
Result
= pfIncludeFile( SourceName
);
/* Clean up after running Forth. */
pfExecIfDefined("AUTO.TERM");
pfDeleteDictionary( dic
);
MSG("pfDoForth: Error occured.\n");
/* Terminate so we restore normal shell tty mode. */
cell_t
pfUnitTest( void )
numErrors
+= pfUnitTestText();