1 /* @(#) pf_core.c 98/01/28 1.5 */
\r
2 /***************************************************************
\r
3 ** Forth based on 'C'
\r
5 ** This file has the main entry points to the pForth library.
\r
8 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\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
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
38 /***************************************************************
\r
40 ***************************************************************/
\r
42 char gScratch[TIB_SIZE];
\r
43 pfTaskData_t *gCurrentTask = NULL;
\r
44 pfDictionary_t *gCurrentDictionary;
\r
45 int32 gNumPrimitives;
\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
52 /* Depth of data stack when colon called. */
\r
53 int32 gDepthAtColon;
\r
55 /* Global Forth variables. */
\r
56 char *gVarContext; /* Points to last name field. */
\r
57 cell gVarState; /* 1 if compiling. */
\r
58 cell gVarBase; /* Numeric Base. */
\r
59 cell gVarEcho; /* Echo input. */
\r
60 cell gVarTraceLevel; /* Trace Level for Inner Interpreter. */
\r
61 cell gVarTraceStack; /* Dump Stack each time if true. */
\r
62 cell gVarTraceFlags; /* Enable various internal debug messages. */
\r
63 cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
\r
64 cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
\r
66 /* data for INCLUDE that allows multiple nested files. */
\r
67 IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];
\r
68 int32 gIncludeIndex;
\r
70 static void pfResetForthTask( void );
\r
71 static void pfInit( void );
\r
72 static void pfTerm( void );
\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
80 /* Initialize globals in a function to simplify loading on
\r
81 * embedded systems which may not support initialization of data section.
\r
83 static void pfInit( void )
\r
86 gCurrentTask = NULL;
\r
87 gCurrentDictionary = NULL;
\r
89 gLocalCompiler_XT = 0;
\r
90 gVarContext = NULL; /* Points to last name field. */
\r
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
100 gVarBase = 10; /* Numeric Base. */
\r
101 gDepthAtColon = DEPTH_AT_COLON_INVALID;
\r
102 gVarTraceStack = 1;
\r
104 pfInitMemoryAllocator();
\r
107 static void pfTerm( void )
\r
112 /***************************************************************
\r
114 ***************************************************************/
\r
116 void pfDeleteTask( PForthTask task )
\r
118 pfTaskData_t *cftd = (pfTaskData_t *)task;
\r
119 FREE_VAR( cftd->td_ReturnLimit );
\r
120 FREE_VAR( cftd->td_StackLimit );
\r
124 /* Allocate some extra cells to protect against mild stack underflows. */
\r
125 #define STACK_SAFETY (8)
\r
126 PForthTask pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth )
\r
128 pfTaskData_t *cftd;
\r
130 cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
\r
131 if( !cftd ) goto nomem;
\r
132 pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
\r
134 /* Allocate User Stack */
\r
135 cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) *
\r
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
141 /* Allocate Return Stack */
\r
142 cftd->td_ReturnLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * ReturnStackDepth) );
\r
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
147 /* Allocate Float Stack */
\r
148 #ifdef PF_SUPPORT_FP
\r
149 /* Allocate room for as many Floats as we do regular data. */
\r
150 cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((uint32)(sizeof(PF_FLOAT) *
\r
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
157 cftd->td_InputStream = PF_STDIN;
\r
159 cftd->td_SourcePtr = &cftd->td_TIB[0];
\r
160 cftd->td_SourceNum = 0;
\r
162 return (PForthTask) cftd;
\r
165 ERR("CreateTaskContext: insufficient memory.\n");
\r
166 if( cftd ) pfDeleteTask( (PForthTask) cftd );
\r
170 /***************************************************************
\r
171 ** Dictionary Management
\r
172 ***************************************************************/
\r
174 int32 pfExecIfDefined( const char *CString )
\r
177 if( NAME_BASE != NULL)
\r
180 if( ffFindC( CString, &XT ) )
\r
182 result = pfCatch( XT );
\r
188 /***************************************************************
\r
189 ** Delete a dictionary created by pfCreateDictionary()
\r
191 void pfDeleteDictionary( PForthDictionary dictionary )
\r
193 pfDictionary_t *dic = (pfDictionary_t *) dictionary;
\r
196 if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
\r
198 FREE_VAR( dic->dic_HeaderBaseUnaligned );
\r
199 FREE_VAR( dic->dic_CodeBaseUnaligned );
\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
211 PForthDictionary pfCreateDictionary( int32 HeaderSize, int32 CodeSize )
\r
213 /* Allocate memory for initial dictionary. */
\r
214 pfDictionary_t *dic;
\r
216 dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
\r
217 if( !dic ) goto nomem;
\r
218 pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
\r
220 dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
\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
224 * to (uint32) on 16 bit systems.
\r
226 #define DIC_ALIGNMENT_SIZE ((uint32)(0x10))
\r
227 #define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)))
\r
229 /* Allocate memory for header. */
\r
230 if( HeaderSize > 0 )
\r
232 dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE );
\r
233 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
\r
234 /* Align header base. */
\r
235 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
\r
236 pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize);
\r
237 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
\r
238 dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase;
\r
242 dic->dic_HeaderBase = NULL;
\r
245 /* Allocate memory for code. */
\r
246 dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE );
\r
247 if( !dic->dic_CodeBaseUnaligned ) goto nomem;
\r
248 dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
\r
249 pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize);
\r
251 dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
\r
252 dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES);
\r
254 return (PForthDictionary) dic;
\r
256 pfDeleteDictionary( dic );
\r
260 /***************************************************************
\r
261 ** Used by Quit and other routines to restore system.
\r
262 ***************************************************************/
\r
264 static void pfResetForthTask( void )
\r
266 /* Go back to terminal input. */
\r
267 gCurrentTask->td_InputStream = PF_STDIN;
\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
276 /* Advance >IN to end of input. */
\r
277 gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
\r
281 /***************************************************************
\r
282 ** Set current task context.
\r
283 ***************************************************************/
\r
285 void pfSetCurrentTask( PForthTask task )
\r
287 gCurrentTask = (pfTaskData_t *) task;
\r
290 /***************************************************************
\r
292 ***************************************************************/
\r
294 void pfSetQuiet( int32 IfQuiet )
\r
296 gVarQuiet = (cell) IfQuiet;
\r
299 /***************************************************************
\r
300 ** Query message status.
\r
301 ***************************************************************/
\r
303 int32 pfQueryQuiet( void )
\r
308 /***************************************************************
\r
309 ** Top level interpreter.
\r
310 ***************************************************************/
\r
311 ThrowCode pfQuit( void )
\r
313 ThrowCode exception;
\r
318 exception = ffOuterInterpreterLoop();
\r
319 if( exception == 0 )
\r
321 exception = ffOK();
\r
324 switch( exception )
\r
336 pfReportThrow( exception );
\r
337 pfHandleIncludeError();
\r
338 pfResetForthTask();
\r
343 return gVarReturnCode;
\r
346 /***************************************************************
\r
347 ** Include file based on 'C' name.
\r
348 ***************************************************************/
\r
350 int32 pfIncludeFile( const char *FileName )
\r
355 int32 numChars, len;
\r
358 fid = sdOpenFile( FileName, "r" );
\r
361 ERR("pfIncludeFile could not open ");
\r
367 /* Create a dictionary word named ::::FileName for FILE? */
\r
368 pfCopyMemory( &buffer[0], "::::", 4);
\r
369 len = (int32) pfCStringLength(FileName);
\r
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
374 Result = ffIncludeFile( fid );
\r
376 /* Create a dictionary word named ;;;; for FILE? */
\r
377 CreateDicEntryC( ID_NOOP, ";;;;", 0 );
\r
383 /***************************************************************
\r
384 ** Output 'C' string message.
\r
385 ** Use sdTerminalOut which works before initializing gCurrentTask.
\r
386 ***************************************************************/
\r
387 void pfDebugMessage( const char *CString )
\r
392 char c = *CString++;
\r
395 sdTerminalOut( 0x0D );
\r
396 sdTerminalOut( 0x0A );
\r
397 pfDebugMessage( "DBG: " );
\r
401 sdTerminalOut( c );
\r
409 /***************************************************************
\r
410 ** Print a decimal number to debug output.
\r
412 void pfDebugPrintDecimalNumber( int n )
\r
414 pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
\r
418 /***************************************************************
\r
419 ** Output 'C' string message.
\r
420 ** This is provided to help avoid the use of printf() and other I/O
\r
421 ** which may not be present on a small embedded system.
\r
422 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
\r
423 ***************************************************************/
\r
424 void pfMessage( const char *CString )
\r
426 ioType( CString, (int32) pfCStringLength(CString) );
\r
429 /**************************************************************************
\r
430 ** Main entry point fo pForth
\r
432 int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit )
\r
434 pfTaskData_t *cftd;
\r
435 pfDictionary_t *dic = NULL;
\r
437 ExecToken EntryPoint = 0;
\r
440 #ifdef PF_USER_INIT
\r
441 Result = PF_USER_INIT;
\r
442 if( Result < 0 ) goto error;
\r
448 /* Allocate Task structure. */
\r
449 pfDebugMessage("pfDoForth: call pfCreateTask()\n");
\r
450 cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
\r
454 pfSetCurrentTask( cftd );
\r
456 if( !pfQueryQuiet() )
\r
458 MSG( "PForth V"PFORTH_VERSION );
\r
459 if( IsHostLittleEndian() ) MSG("LE");
\r
461 #if PF_BIG_ENDIAN_DIC
\r
463 #elif PF_LITTLE_ENDIAN_DIC
\r
466 MSG( ", built "__DATE__" "__TIME__ );
\r
469 /* Don't use MSG before task set. */
\r
472 pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
\r
476 #ifdef PF_NO_GLOBAL_INIT
\r
477 if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */
\r
480 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
\r
483 pfDebugMessage("Build dictionary from scratch.\n");
\r
484 dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
\r
489 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
\r
493 pfDebugMessage("DicName = "); pfDebugMessage(DicName); pfDebugMessage("\n");
\r
495 dic = pfLoadDictionary( DicName, &EntryPoint );
\r
501 dic = pfLoadStaticDictionary();
\r
504 if( dic == NULL ) goto error;
\r
507 pfDebugMessage("pfDoForth: try AUTO.INIT\n");
\r
508 Result = pfExecIfDefined("AUTO.INIT");
\r
511 MSG("Error in AUTO.INIT");
\r
515 if( EntryPoint != 0 )
\r
517 Result = pfCatch( EntryPoint );
\r
519 #ifndef PF_NO_SHELL
\r
522 if( SourceName == NULL )
\r
524 pfDebugMessage("pfDoForth: pfQuit\n");
\r
531 MSG("Including: ");
\r
535 Result = pfIncludeFile( SourceName );
\r
538 #endif /* PF_NO_SHELL */
\r
540 /* Clean up after running Forth. */
\r
541 pfExecIfDefined("AUTO.TERM");
\r
542 pfDeleteDictionary( dic );
\r
543 pfDeleteTask( cftd );
\r
548 #ifdef PF_USER_TERM
\r
555 MSG("pfDoForth: Error occured.\n");
\r
556 pfDeleteTask( cftd );
\r