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 #define DEFAULT_RETURN_DEPTH (512)
75 #define DEFAULT_USER_DEPTH (512)
77 #ifndef PF_DEFAULT_HEADER_SIZE
78 #define PF_DEFAULT_HEADER_SIZE (120000)
81 #ifndef PF_DEFAULT_CODE_SIZE
82 #define PF_DEFAULT_CODE_SIZE (300000)
85 /* Initialize globals in a function to simplify loading on
86 * embedded systems which may not support initialization of data section.
88 static void pfInit( void )
92 gCurrentDictionary = NULL;
94 gLocalCompiler_XT = 0;
95 gVarContext = (cell_t)NULL; /* Points to last name field. */
96 gVarState = 0; /* 1 if compiling. */
97 gVarEcho = 0; /* Echo input. */
98 gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */
99 gVarTraceFlags = 0; /* Enable various internal debug messages. */
100 gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */
104 gVarBase = 10; /* Numeric Base. */
105 gDepthAtColon = DEPTH_AT_COLON_INVALID;
108 pfInitMemoryAllocator();
111 static void pfTerm( void )
116 /***************************************************************
118 ***************************************************************/
120 void pfDeleteTask( PForthTask task )
122 pfTaskData_t *cftd = (pfTaskData_t *)task;
123 FREE_VAR( cftd->td_ReturnLimit );
124 FREE_VAR( cftd->td_StackLimit );
128 /* Allocate some extra cells to protect against mild stack underflows. */
129 #define STACK_SAFETY (8)
130 PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
134 cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
135 if( !cftd ) goto nomem;
136 pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
138 /* Allocate User Stack */
139 cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
140 (UserStackDepth + STACK_SAFETY)));
141 if( !cftd->td_StackLimit ) goto nomem;
142 cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
143 cftd->td_StackPtr = cftd->td_StackBase;
145 /* Allocate Return Stack */
146 cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
147 if( !cftd->td_ReturnLimit ) goto nomem;
148 cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
149 cftd->td_ReturnPtr = cftd->td_ReturnBase;
151 /* Allocate Float Stack */
153 /* Allocate room for as many Floats as we do regular data. */
154 cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
155 (UserStackDepth + STACK_SAFETY)));
156 if( !cftd->td_FloatStackLimit ) goto nomem;
157 cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
158 cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
161 cftd->td_InputStream = PF_STDIN;
163 cftd->td_SourcePtr = &cftd->td_TIB[0];
164 cftd->td_SourceNum = 0;
166 return (PForthTask) cftd;
169 ERR("CreateTaskContext: insufficient memory.\n");
170 if( cftd ) pfDeleteTask( (PForthTask) cftd );
174 /***************************************************************
175 ** Dictionary Management
176 ***************************************************************/
178 ThrowCode pfExecIfDefined( const char *CString )
180 ThrowCode result = 0;
181 if( NAME_BASE != (cell_t)NULL)
184 if( ffFindC( CString, &XT ) )
186 result = pfCatch( XT );
192 /***************************************************************
193 ** Delete a dictionary created by pfCreateDictionary()
195 void pfDeleteDictionary( PForthDictionary dictionary )
197 pfDictionary_t *dic = (pfDictionary_t *) dictionary;
200 if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
202 FREE_VAR( dic->dic_HeaderBaseUnaligned );
203 FREE_VAR( dic->dic_CodeBaseUnaligned );
208 /***************************************************************
209 ** Create a complete dictionary.
210 ** The dictionary consists of two parts, the header with the names,
211 ** and the code portion.
212 ** Delete using pfDeleteDictionary().
213 ** Return pointer to dictionary management structure.
215 PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
217 /* Allocate memory for initial dictionary. */
220 dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
221 if( !dic ) goto nomem;
222 pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
224 dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
226 /* Align dictionary segments to preserve alignment of floats across hosts.
227 * Thank you Helmut Proelss for pointing out that this needs to be cast
228 * to (ucell_t) on 16 bit systems.
230 #define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))
231 #define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
233 /* Allocate memory for header. */
236 dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
237 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
238 /* Align header base. */
239 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
240 pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
241 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
242 dic->dic_HeaderPtr = dic->dic_HeaderBase;
246 dic->dic_HeaderBase = 0;
249 /* Allocate memory for code. */
250 dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
251 if( !dic->dic_CodeBaseUnaligned ) goto nomem;
252 dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
253 pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
255 dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
256 dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
258 return (PForthDictionary) dic;
260 pfDeleteDictionary( dic );
264 /***************************************************************
265 ** Used by Quit and other routines to restore system.
266 ***************************************************************/
268 static void pfResetForthTask( void )
270 /* Go back to terminal input. */
271 gCurrentTask->td_InputStream = PF_STDIN;
274 gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
275 gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
276 #ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */
277 gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
280 /* Advance >IN to end of input. */
281 gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
285 /***************************************************************
286 ** Set current task context.
287 ***************************************************************/
289 void pfSetCurrentTask( PForthTask task )
291 gCurrentTask = (pfTaskData_t *) task;
294 /***************************************************************
296 ***************************************************************/
298 void pfSetQuiet( cell_t IfQuiet )
300 gVarQuiet = (cell_t) IfQuiet;
303 /***************************************************************
304 ** Query message status.
305 ***************************************************************/
307 cell_t pfQueryQuiet( void )
312 /***************************************************************
313 ** Top level interpreter.
314 ***************************************************************/
315 ThrowCode pfQuit( void )
322 exception = ffOuterInterpreterLoop();
340 pfReportThrow( exception );
341 pfHandleIncludeError();
347 return gVarReturnCode;
350 /***************************************************************
351 ** Include file based on 'C' name.
352 ***************************************************************/
354 cell_t pfIncludeFile( const char *FileName )
359 cell_t numChars, len;
362 fid = sdOpenFile( FileName, "r" );
365 ERR("pfIncludeFile could not open ");
371 /* Create a dictionary word named ::::FileName for FILE? */
372 pfCopyMemory( &buffer[0], "::::", 4);
373 len = (cell_t) pfCStringLength(FileName);
374 numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
375 pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
376 CreateDicEntryC( ID_NOOP, buffer, 0 );
378 Result = ffIncludeFile( fid ); /* Also close the file. */
380 /* Create a dictionary word named ;;;; for FILE? */
381 CreateDicEntryC( ID_NOOP, ";;;;", 0 );
386 /***************************************************************
387 ** Output 'C' string message.
388 ** Use sdTerminalOut which works before initializing gCurrentTask.
389 ***************************************************************/
390 void pfDebugMessage( const char *CString )
398 sdTerminalOut( 0x0D );
399 sdTerminalOut( 0x0A );
400 pfDebugMessage( "DBG: " );
412 /***************************************************************
413 ** Print a decimal number to debug output.
415 void pfDebugPrintDecimalNumber( int n )
417 pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
421 /***************************************************************
422 ** Output 'C' string message.
423 ** This is provided to help avoid the use of printf() and other I/O
424 ** which may not be present on a small embedded system.
425 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
426 ***************************************************************/
427 void pfMessage( const char *CString )
429 ioType( CString, (cell_t) pfCStringLength(CString) );
432 /**************************************************************************
433 ** Main entry point for pForth.
435 ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
438 pfDictionary_t *dic = NULL;
439 ThrowCode Result = 0;
440 ExecToken EntryPoint = 0;
443 Result = PF_USER_INIT;
444 if( Result < 0 ) goto error1;
449 /* Allocate Task structure. */
450 pfDebugMessage("pfDoForth: call pfCreateTask()\n");
451 cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
455 pfSetCurrentTask( cftd );
459 MSG( "PForth V"PFORTH_VERSION );
460 if( IsHostLittleEndian() ) MSG("-LE");
462 #if PF_BIG_ENDIAN_DIC
464 #elif PF_LITTLE_ENDIAN_DIC
467 if (sizeof(cell_t) == 8)
471 else if (sizeof(cell_t) == 4)
476 MSG( ", built "__DATE__" "__TIME__ );
479 /* Don't use MSG before task set. */
482 pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
486 #ifdef PF_NO_GLOBAL_INIT
487 if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
490 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
493 pfDebugMessage("Build dictionary from scratch.\n");
494 dic = pfBuildDictionary( PF_DEFAULT_HEADER_SIZE, PF_DEFAULT_CODE_SIZE );
499 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
503 pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
508 dic = pfLoadDictionary( DicFileName, &EntryPoint );
517 dic = pfLoadStaticDictionary();
520 if( dic == NULL ) goto error2;
527 pfDebugMessage("pfDoForth: try AUTO.INIT\n");
528 Result = pfExecIfDefined("AUTO.INIT");
531 MSG("Error in AUTO.INIT");
535 if( EntryPoint != 0 )
537 Result = pfCatch( EntryPoint );
542 if( SourceName == NULL )
544 pfDebugMessage("pfDoForth: pfQuit\n");
555 Result = pfIncludeFile( SourceName );
558 #endif /* PF_NO_SHELL */
560 /* Clean up after running Forth. */
561 pfExecIfDefined("AUTO.TERM");
562 pfDeleteDictionary( dic );
563 pfDeleteTask( cftd );
575 MSG("pfDoForth: Error occured.\n");
576 pfDeleteTask( cftd );
577 /* Terminate so we restore normal shell tty mode. */
589 cell_t pfUnitTest( void )
591 cell_t numErrors = 0;
592 numErrors += pfUnitTestText();