1 /* @(#) pf_core.c 98/01/28 1.5 */
2 /***************************************************************
5 ** This file has the main entry points to the pForth library.
8 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
10 ** The pForth software code is dedicated to the public domain,
11 ** and any third party may reproduce, distribute and modify
12 ** the pForth software code or any derivative works thereof
13 ** without any compensation or license. The pForth software
14 ** code is provided on an "as is" basis without any warranty
15 ** of any kind, including, without limitation, the implied
16 ** warranties of merchantability and fitness for a particular
17 ** purpose and their equivalents under the laws of any jurisdiction.
19 ****************************************************************
20 ** 940502 PLB Creation.
21 ** 940505 PLB More macros.
22 ** 940509 PLB Moved all stack handling into inner interpreter.
23 ** Added Create, Colon, Semicolon, HNumberQ, etc.
24 ** 940510 PLB Got inner interpreter working with secondaries.
25 ** Added (LITERAL). Compiles colon definitions.
26 ** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
27 ** 940512 PLB Added DO LOOP DEFER, fixed R>
28 ** 940520 PLB Added INCLUDE
29 ** 940521 PLB Added NUMBER?
30 ** 940930 PLB Outer Interpreter now uses deferred NUMBER?
31 ** 941005 PLB Added ANSI locals, LEAVE, modularised
32 ** 950320 RDG Added underflow checking for FP stack
33 ** 970702 PLB Added STACK_SAFETY to FP stack size.
34 ***************************************************************/
38 /***************************************************************
40 ***************************************************************/
42 char gScratch[TIB_SIZE];
43 pfTaskData_t *gCurrentTask = NULL;
44 pfDictionary_t *gCurrentDictionary;
45 cell_t gNumPrimitives;
47 ExecToken gLocalCompiler_XT; /* custom compiler for local variables */
48 ExecToken gNumberQ_XT; /* XT of NUMBER? */
49 ExecToken gQuitP_XT; /* XT of (QUIT) */
50 ExecToken gAcceptP_XT; /* XT of ACCEPT */
52 /* Depth of data stack when colon called. */
55 /* Global Forth variables. */
56 cell_t gVarContext; /* Points to last name field. */
57 cell_t gVarState; /* 1 if compiling. */
58 cell_t gVarBase; /* Numeric Base. */
59 cell_t gVarEcho; /* Echo input. */
60 cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */
61 cell_t gVarTraceStack; /* Dump Stack each time if true. */
62 cell_t gVarTraceFlags; /* Enable various internal debug messages. */
63 cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
64 cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
66 /* data for INCLUDE that allows multiple nested files. */
67 IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];
70 static void pfResetForthTask( void );
71 static void pfInit( void );
72 static void pfTerm( void );
74 /* TODO move to pf_config.h header. */
75 #define DEFAULT_RETURN_DEPTH (512)
76 #define DEFAULT_USER_DEPTH (512)
77 #define DEFAULT_HEADER_SIZE (120000)
78 #define DEFAULT_CODE_SIZE (300000)
80 /* Initialize globals in a function to simplify loading on
81 * embedded systems which may not support initialization of data section.
83 static void pfInit( void )
87 gCurrentDictionary = NULL;
89 gLocalCompiler_XT = 0;
90 gVarContext = (cell_t)NULL; /* Points to last name field. */
91 gVarState = 0; /* 1 if compiling. */
92 gVarEcho = 0; /* Echo input. */
93 gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */
94 gVarTraceFlags = 0; /* Enable various internal debug messages. */
95 gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */
99 gVarBase = 10; /* Numeric Base. */
100 gDepthAtColon = DEPTH_AT_COLON_INVALID;
103 pfInitMemoryAllocator();
106 static void pfTerm( void )
111 /***************************************************************
113 ***************************************************************/
115 void pfDeleteTask( PForthTask task )
117 pfTaskData_t *cftd = (pfTaskData_t *)task;
118 FREE_VAR( cftd->td_ReturnLimit );
119 FREE_VAR( cftd->td_StackLimit );
123 /* Allocate some extra cells to protect against mild stack underflows. */
124 #define STACK_SAFETY (8)
125 PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
129 cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
130 if( !cftd ) goto nomem;
131 pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
133 /* Allocate User Stack */
134 cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
135 (UserStackDepth + STACK_SAFETY)));
136 if( !cftd->td_StackLimit ) goto nomem;
137 cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
138 cftd->td_StackPtr = cftd->td_StackBase;
140 /* Allocate Return Stack */
141 cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
142 if( !cftd->td_ReturnLimit ) goto nomem;
143 cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
144 cftd->td_ReturnPtr = cftd->td_ReturnBase;
146 /* Allocate Float Stack */
148 /* Allocate room for as many Floats as we do regular data. */
149 cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
150 (UserStackDepth + STACK_SAFETY)));
151 if( !cftd->td_FloatStackLimit ) goto nomem;
152 cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
153 cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
156 cftd->td_InputStream = PF_STDIN;
158 cftd->td_SourcePtr = &cftd->td_TIB[0];
159 cftd->td_SourceNum = 0;
161 return (PForthTask) cftd;
164 ERR("CreateTaskContext: insufficient memory.\n");
165 if( cftd ) pfDeleteTask( (PForthTask) cftd );
169 /***************************************************************
170 ** Dictionary Management
171 ***************************************************************/
173 ThrowCode pfExecIfDefined( const char *CString )
175 ThrowCode result = 0;
176 if( NAME_BASE != (cell_t)NULL)
179 if( ffFindC( CString, &XT ) )
181 result = pfCatch( XT );
187 /***************************************************************
188 ** Delete a dictionary created by pfCreateDictionary()
190 void pfDeleteDictionary( PForthDictionary dictionary )
192 pfDictionary_t *dic = (pfDictionary_t *) dictionary;
195 if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
197 FREE_VAR( dic->dic_HeaderBaseUnaligned );
198 FREE_VAR( dic->dic_CodeBaseUnaligned );
203 /***************************************************************
204 ** Create a complete dictionary.
205 ** The dictionary consists of two parts, the header with the names,
206 ** and the code portion.
207 ** Delete using pfDeleteDictionary().
208 ** Return pointer to dictionary management structure.
210 PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
212 /* Allocate memory for initial dictionary. */
215 dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
216 if( !dic ) goto nomem;
217 pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
219 dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
221 /* Align dictionary segments to preserve alignment of floats across hosts.
222 * Thank you Helmut Proelss for pointing out that this needs to be cast
223 * to (ucell_t) on 16 bit systems.
225 #define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))
226 #define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
228 /* Allocate memory for header. */
231 dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
232 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
233 /* Align header base. */
234 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
235 pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
236 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
237 dic->dic_HeaderPtr = dic->dic_HeaderBase;
241 dic->dic_HeaderBase = 0;
244 /* Allocate memory for code. */
245 dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
246 if( !dic->dic_CodeBaseUnaligned ) goto nomem;
247 dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
248 pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
250 dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
251 dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
253 return (PForthDictionary) dic;
255 pfDeleteDictionary( dic );
259 /***************************************************************
260 ** Used by Quit and other routines to restore system.
261 ***************************************************************/
263 static void pfResetForthTask( void )
265 /* Go back to terminal input. */
266 gCurrentTask->td_InputStream = PF_STDIN;
269 gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
270 gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
271 #ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */
272 gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
275 /* Advance >IN to end of input. */
276 gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
280 /***************************************************************
281 ** Set current task context.
282 ***************************************************************/
284 void pfSetCurrentTask( PForthTask task )
286 gCurrentTask = (pfTaskData_t *) task;
289 /***************************************************************
291 ***************************************************************/
293 void pfSetQuiet( cell_t IfQuiet )
295 gVarQuiet = (cell_t) IfQuiet;
298 /***************************************************************
299 ** Query message status.
300 ***************************************************************/
302 cell_t pfQueryQuiet( void )
307 /***************************************************************
308 ** Top level interpreter.
309 ***************************************************************/
310 ThrowCode pfQuit( void )
317 exception = ffOuterInterpreterLoop();
335 pfReportThrow( exception );
336 pfHandleIncludeError();
342 return gVarReturnCode;
345 /***************************************************************
346 ** Include file based on 'C' name.
347 ***************************************************************/
349 cell_t pfIncludeFile( const char *FileName )
354 cell_t numChars, len;
357 fid = sdOpenFile( FileName, "r" );
360 ERR("pfIncludeFile could not open ");
366 /* Create a dictionary word named ::::FileName for FILE? */
367 pfCopyMemory( &buffer[0], "::::", 4);
368 len = (cell_t) pfCStringLength(FileName);
369 numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
370 pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
371 CreateDicEntryC( ID_NOOP, buffer, 0 );
373 Result = ffIncludeFile( fid ); /* Also close the file. */
375 /* Create a dictionary word named ;;;; for FILE? */
376 CreateDicEntryC( ID_NOOP, ";;;;", 0 );
381 /***************************************************************
382 ** Output 'C' string message.
383 ** Use sdTerminalOut which works before initializing gCurrentTask.
384 ***************************************************************/
385 void pfDebugMessage( const char *CString )
393 sdTerminalOut( 0x0D );
394 sdTerminalOut( 0x0A );
395 pfDebugMessage( "DBG: " );
407 /***************************************************************
408 ** Print a decimal number to debug output.
410 void pfDebugPrintDecimalNumber( int n )
412 pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
416 /***************************************************************
417 ** Output 'C' string message.
418 ** This is provided to help avoid the use of printf() and other I/O
419 ** which may not be present on a small embedded system.
420 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
421 ***************************************************************/
422 void pfMessage( const char *CString )
424 ioType( CString, (cell_t) pfCStringLength(CString) );
427 /**************************************************************************
428 ** Main entry point for pForth.
430 ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
433 pfDictionary_t *dic = NULL;
434 ThrowCode Result = 0;
435 ExecToken EntryPoint = 0;
438 Result = PF_USER_INIT;
439 if( Result < 0 ) goto error1;
444 /* Allocate Task structure. */
445 pfDebugMessage("pfDoForth: call pfCreateTask()\n");
446 cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
450 pfSetCurrentTask( cftd );
454 MSG( "PForth V"PFORTH_VERSION );
455 if( IsHostLittleEndian() ) MSG("-LE");
457 #if PF_BIG_ENDIAN_DIC
459 #elif PF_LITTLE_ENDIAN_DIC
462 if (sizeof(cell_t) == 8)
466 else if (sizeof(cell_t) == 4)
471 MSG( ", built "__DATE__" "__TIME__ );
474 /* Don't use MSG before task set. */
477 pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
481 #ifdef PF_NO_GLOBAL_INIT
482 if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
485 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
488 pfDebugMessage("Build dictionary from scratch.\n");
489 dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
494 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
498 pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
503 dic = pfLoadDictionary( DicFileName, &EntryPoint );
512 dic = pfLoadStaticDictionary();
515 if( dic == NULL ) goto error2;
522 pfDebugMessage("pfDoForth: try AUTO.INIT\n");
523 Result = pfExecIfDefined("AUTO.INIT");
526 MSG("Error in AUTO.INIT");
530 if( EntryPoint != 0 )
532 Result = pfCatch( EntryPoint );
537 if( SourceName == NULL )
539 pfDebugMessage("pfDoForth: pfQuit\n");
550 Result = pfIncludeFile( SourceName );
553 #endif /* PF_NO_SHELL */
555 /* Clean up after running Forth. */
556 pfExecIfDefined("AUTO.TERM");
557 pfDeleteDictionary( dic );
558 pfDeleteTask( cftd );
570 MSG("pfDoForth: Error occured.\n");
571 pfDeleteTask( cftd );
572 /* Terminate so we restore normal shell tty mode. */
584 cell_t pfUnitTest( void )
586 cell_t numErrors = 0;
587 numErrors += pfUnitTestText();