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 ** Permission to use, copy, modify, and/or distribute this
11 ** software for any purpose with or without fee is hereby granted.
13 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
14 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
15 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
16 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
17 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
18 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
19 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
20 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
22 ****************************************************************
23 ** 940502 PLB Creation.
24 ** 940505 PLB More macros.
25 ** 940509 PLB Moved all stack handling into inner interpreter.
26 ** Added Create, Colon, Semicolon, HNumberQ, etc.
27 ** 940510 PLB Got inner interpreter working with secondaries.
28 ** Added (LITERAL). Compiles colon definitions.
29 ** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
30 ** 940512 PLB Added DO LOOP DEFER, fixed R>
31 ** 940520 PLB Added INCLUDE
32 ** 940521 PLB Added NUMBER?
33 ** 940930 PLB Outer Interpreter now uses deferred NUMBER?
34 ** 941005 PLB Added ANSI locals, LEAVE, modularised
35 ** 950320 RDG Added underflow checking for FP stack
36 ** 970702 PLB Added STACK_SAFETY to FP stack size.
37 ***************************************************************/
41 /***************************************************************
43 ***************************************************************/
45 char gScratch[TIB_SIZE];
46 pfTaskData_t *gCurrentTask = NULL;
47 pfDictionary_t *gCurrentDictionary;
48 cell_t gNumPrimitives;
50 ExecToken gLocalCompiler_XT; /* custom compiler for local variables */
51 ExecToken gNumberQ_XT; /* XT of NUMBER? */
52 ExecToken gQuitP_XT; /* XT of (QUIT) */
53 ExecToken gAcceptP_XT; /* XT of ACCEPT */
55 /* Depth of data stack when colon called. */
58 /* Global Forth variables.
59 * These must be initialized in pfInit below.
61 cell_t gVarContext; /* Points to last name field. */
62 cell_t gVarState; /* 1 if compiling. */
63 cell_t gVarBase; /* Numeric Base. */
64 cell_t gVarByeCode; /* Echo input. */
65 cell_t gVarEcho; /* Echo input. */
66 cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */
67 cell_t gVarTraceStack; /* Dump Stack each time if true. */
68 cell_t gVarTraceFlags; /* Enable various internal debug messages. */
69 cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
70 cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
72 /* data for INCLUDE that allows multiple nested files. */
73 IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];
76 static void pfResetForthTask( void );
77 static void pfInit( void );
78 static void pfTerm( void );
80 #define DEFAULT_RETURN_DEPTH (512)
81 #define DEFAULT_USER_DEPTH (512)
83 #ifndef PF_DEFAULT_HEADER_SIZE
84 #define PF_DEFAULT_HEADER_SIZE (120000)
87 #ifndef PF_DEFAULT_CODE_SIZE
88 #define PF_DEFAULT_CODE_SIZE (300000)
91 /* Initialize globals in a function to simplify loading on
92 * embedded systems which may not support initialization of data section.
94 static void pfInit( void )
98 gCurrentDictionary = NULL;
100 gLocalCompiler_XT = 0;
101 gVarContext = (cell_t)NULL; /* Points to last name field. */
102 gVarState = 0; /* 1 if compiling. */
103 gVarByeCode = 0; /* BYE-CODE */
104 gVarEcho = 0; /* Echo input. */
105 gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */
106 gVarTraceFlags = 0; /* Enable various internal debug messages. */
107 gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */
111 gVarBase = 10; /* Numeric Base. */
112 gDepthAtColon = DEPTH_AT_COLON_INVALID;
115 pfInitMemoryAllocator();
118 static void pfTerm( void )
123 /***************************************************************
125 ***************************************************************/
127 void pfDeleteTask( PForthTask task )
129 pfTaskData_t *cftd = (pfTaskData_t *)task;
130 FREE_VAR( cftd->td_ReturnLimit );
131 FREE_VAR( cftd->td_StackLimit );
135 /* Allocate some extra cells to protect against mild stack underflows. */
136 #define STACK_SAFETY (8)
137 PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
141 cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
142 if( !cftd ) goto nomem;
143 pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
145 /* Allocate User Stack */
146 cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
147 (UserStackDepth + STACK_SAFETY)));
148 if( !cftd->td_StackLimit ) goto nomem;
149 cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
150 cftd->td_StackPtr = cftd->td_StackBase;
152 /* Allocate Return Stack */
153 cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
154 if( !cftd->td_ReturnLimit ) goto nomem;
155 cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
156 cftd->td_ReturnPtr = cftd->td_ReturnBase;
158 /* Allocate Float Stack */
160 /* Allocate room for as many Floats as we do regular data. */
161 cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
162 (UserStackDepth + STACK_SAFETY)));
163 if( !cftd->td_FloatStackLimit ) goto nomem;
164 cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
165 cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
168 cftd->td_InputStream = PF_STDIN;
170 cftd->td_SourcePtr = &cftd->td_TIB[0];
171 cftd->td_SourceNum = 0;
173 return (PForthTask) cftd;
176 ERR("CreateTaskContext: insufficient memory.\n");
177 if( cftd ) pfDeleteTask( (PForthTask) cftd );
181 /***************************************************************
182 ** Dictionary Management
183 ***************************************************************/
185 ThrowCode pfExecIfDefined( const char *CString )
187 ThrowCode result = 0;
188 if( NAME_BASE != (cell_t)NULL)
191 if( ffFindC( CString, &XT ) )
193 result = pfCatch( XT );
199 /***************************************************************
200 ** Delete a dictionary created by pfCreateDictionary()
202 void pfDeleteDictionary( PForthDictionary dictionary )
204 pfDictionary_t *dic = (pfDictionary_t *) dictionary;
207 if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
209 FREE_VAR( dic->dic_HeaderBaseUnaligned );
210 FREE_VAR( dic->dic_CodeBaseUnaligned );
215 /***************************************************************
216 ** Create a complete dictionary.
217 ** The dictionary consists of two parts, the header with the names,
218 ** and the code portion.
219 ** Delete using pfDeleteDictionary().
220 ** Return pointer to dictionary management structure.
222 PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
224 /* Allocate memory for initial dictionary. */
227 dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
228 if( !dic ) goto nomem;
229 pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
231 dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
233 /* Align dictionary segments to preserve alignment of floats across hosts.
234 * Thank you Helmut Proelss for pointing out that this needs to be cast
235 * to (ucell_t) on 16 bit systems.
237 #define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))
238 #define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
240 /* Allocate memory for header. */
243 dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
244 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
245 /* Align header base. */
246 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
247 pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
248 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
249 dic->dic_HeaderPtr = dic->dic_HeaderBase;
253 dic->dic_HeaderBase = 0;
256 /* Allocate memory for code. */
257 dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
258 if( !dic->dic_CodeBaseUnaligned ) goto nomem;
259 dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
260 pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
262 dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
263 dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
265 return (PForthDictionary) dic;
267 pfDeleteDictionary( dic );
271 /***************************************************************
272 ** Used by Quit and other routines to restore system.
273 ***************************************************************/
275 static void pfResetForthTask( void )
277 /* Go back to terminal input. */
278 gCurrentTask->td_InputStream = PF_STDIN;
281 gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
282 gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
283 #ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */
284 gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
287 /* Advance >IN to end of input. */
288 gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
292 /***************************************************************
293 ** Set current task context.
294 ***************************************************************/
296 void pfSetCurrentTask( PForthTask task )
298 gCurrentTask = (pfTaskData_t *) task;
301 /***************************************************************
303 ***************************************************************/
305 void pfSetQuiet( cell_t IfQuiet )
307 gVarQuiet = (cell_t) IfQuiet;
310 /***************************************************************
311 ** Query message status.
312 ***************************************************************/
314 cell_t pfQueryQuiet( void )
319 /***************************************************************
320 ** Top level interpreter.
321 ***************************************************************/
322 ThrowCode pfQuit( void )
329 exception = ffOuterInterpreterLoop();
347 pfReportThrow( exception );
348 pfHandleIncludeError();
354 return gVarReturnCode;
357 /***************************************************************
358 ** Include file based on 'C' name.
359 ***************************************************************/
361 cell_t pfIncludeFile( const char *FileName )
366 cell_t numChars, len;
369 fid = sdOpenFile( FileName, "r" );
372 ERR("pfIncludeFile could not open ");
378 /* Create a dictionary word named ::::FileName for FILE? */
379 pfCopyMemory( &buffer[0], "::::", 4);
380 len = (cell_t) pfCStringLength(FileName);
381 numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
382 pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
383 CreateDicEntryC( ID_NOOP, buffer, 0 );
385 Result = ffIncludeFile( fid ); /* Also close the file. */
387 /* Create a dictionary word named ;;;; for FILE? */
388 CreateDicEntryC( ID_NOOP, ";;;;", 0 );
393 /***************************************************************
394 ** Output 'C' string message.
395 ** Use sdTerminalOut which works before initializing gCurrentTask.
396 ***************************************************************/
397 void pfDebugMessage( const char *CString )
405 sdTerminalOut( 0x0D );
406 sdTerminalOut( 0x0A );
407 pfDebugMessage( "DBG: " );
419 /***************************************************************
420 ** Print a decimal number to debug output.
422 void pfDebugPrintDecimalNumber( int n )
424 pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
428 /***************************************************************
429 ** Output 'C' string message.
430 ** This is provided to help avoid the use of printf() and other I/O
431 ** which may not be present on a small embedded system.
432 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
433 ***************************************************************/
434 void pfMessage( const char *CString )
436 ioType( CString, (cell_t) pfCStringLength(CString) );
439 /**************************************************************************
440 ** Main entry point for pForth.
442 ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
445 pfDictionary_t *dic = NULL;
446 ThrowCode Result = 0;
447 ExecToken EntryPoint = 0;
450 Result = PF_USER_INIT;
451 if( Result < 0 ) goto error1;
456 /* Allocate Task structure. */
457 pfDebugMessage("pfDoForth: call pfCreateTask()\n");
458 cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
462 pfSetCurrentTask( cftd );
466 MSG( "PForth V"PFORTH_VERSION );
467 if( IsHostLittleEndian() ) MSG("-LE");
469 #if PF_BIG_ENDIAN_DIC
471 #elif PF_LITTLE_ENDIAN_DIC
474 if (sizeof(cell_t) == 8)
478 else if (sizeof(cell_t) == 4)
483 MSG( ", built "__DATE__" "__TIME__ );
486 /* Don't use MSG before task set. */
489 pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
493 #ifdef PF_NO_GLOBAL_INIT
494 if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
497 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
500 pfDebugMessage("Build dictionary from scratch.\n");
501 dic = pfBuildDictionary( PF_DEFAULT_HEADER_SIZE, PF_DEFAULT_CODE_SIZE );
506 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
510 pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
515 dic = pfLoadDictionary( DicFileName, &EntryPoint );
524 dic = pfLoadStaticDictionary();
527 if( dic == NULL ) goto error2;
534 pfDebugMessage("pfDoForth: try AUTO.INIT\n");
535 Result = pfExecIfDefined("AUTO.INIT");
538 MSG("Error in AUTO.INIT");
542 if( EntryPoint != 0 )
544 Result = pfCatch( EntryPoint );
549 if( SourceName == NULL )
551 pfDebugMessage("pfDoForth: pfQuit\n");
562 Result = pfIncludeFile( SourceName );
565 #endif /* PF_NO_SHELL */
567 /* Clean up after running Forth. */
568 pfExecIfDefined("AUTO.TERM");
569 pfDeleteDictionary( dic );
570 pfDeleteTask( cftd );
579 return Result ? Result : gVarByeCode;
582 MSG("pfDoForth: Error occured.\n");
583 pfDeleteTask( cftd );
584 /* Terminate so we restore normal shell tty mode. */
596 cell_t pfUnitTest( void )
598 cell_t numErrors = 0;
599 numErrors += pfUnitTestText();