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, Devid 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 cfTaskData *gCurrentTask;
43 cfDictionary *gCurrentDictionary;
45 char gScratch[TIB_SIZE];
46 ExecToken gLocalCompiler_XT; /* custom compiler for local variables */
48 /* Depth of data stack when colon called. */
51 /* Global Forth variables. */
52 char *gVarContext; /* Points to last name field. */
53 cell gVarState; /* 1 if compiling. */
54 cell gVarBase; /* Numeric Base. */
55 cell gVarEcho; /* Echo input. */
56 cell gVarTraceLevel; /* Trace Level for Inner Interpreter. */
57 cell gVarTraceStack; /* Dump Stack each time if true. */
58 cell gVarTraceFlags; /* Enable various internal debug messages. */
59 cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
60 cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
62 #define DEFAULT_RETURN_DEPTH (512)
63 #define DEFAULT_USER_DEPTH (512)
64 #define DEFAULT_HEADER_SIZE (120000)
65 #define DEFAULT_CODE_SIZE (300000)
67 /* Initialize non-zero globals in a function to simplify loading on
68 * embedded systems which may only support uninitialized data segments.
70 void pfInitGlobals( void )
74 gDepthAtColon = DEPTH_AT_COLON_INVALID;
77 /***************************************************************
79 ***************************************************************/
81 void pfDeleteTask( cfTaskData *cftd )
83 FREE_VAR( cftd->td_ReturnLimit );
84 FREE_VAR( cftd->td_StackLimit );
87 /* Allocate some extra cells to protect against mild stack underflows. */
88 #define STACK_SAFETY (8)
89 cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth )
93 cftd = ( cfTaskData * ) pfAllocMem( sizeof( cfTaskData ) );
94 if( !cftd ) goto nomem;
95 pfSetMemory( cftd, 0, sizeof( cfTaskData ));
97 /* Allocate User Stack */
98 cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) *
99 (UserStackDepth + STACK_SAFETY)));
100 if( !cftd->td_StackLimit ) goto nomem;
101 cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
102 cftd->td_StackPtr = cftd->td_StackBase;
104 /* Allocate Return Stack */
105 cftd->td_ReturnLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * ReturnStackDepth) );
106 if( !cftd->td_ReturnLimit ) goto nomem;
107 cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
108 cftd->td_ReturnPtr = cftd->td_ReturnBase;
110 /* Allocate Float Stack */
112 /* Allocate room for as many Floats as we do regular data. */
113 cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((uint32)(sizeof(PF_FLOAT) *
114 (UserStackDepth + STACK_SAFETY)));
115 if( !cftd->td_FloatStackLimit ) goto nomem;
116 cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
117 cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
120 cftd->td_InputStream = PF_STDIN;
122 cftd->td_SourcePtr = &cftd->td_TIB[0];
123 cftd->td_SourceNum = 0;
128 ERR("CreateTaskContext: insufficient memory.\n");
129 if( cftd ) pfDeleteTask( cftd );
133 /***************************************************************
134 ** Dictionary Management
135 ***************************************************************/
137 void pfExecByName( const char *CString )
139 if( NAME_BASE != NULL)
141 ExecToken autoInitXT;
142 if( ffFindC( CString, &autoInitXT ) )
144 pfExecuteToken( autoInitXT );
149 /***************************************************************
150 ** Delete a dictionary created by pfCreateDictionary()
152 void pfDeleteDictionary( cfDictionary *dic )
156 if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
158 FREE_VAR( dic->dic_HeaderBaseUnaligned );
159 FREE_VAR( dic->dic_CodeBaseUnaligned );
164 /***************************************************************
165 ** Create a complete dictionary.
166 ** The dictionary consists of two parts, the header with the names,
167 ** and the code portion.
168 ** Delete using pfDeleteDictionary().
169 ** Return pointer to dictionary management structure.
171 cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize )
173 /* Allocate memory for initial dictionary. */
176 dic = ( cfDictionary * ) pfAllocMem( sizeof( cfDictionary ) );
177 if( !dic ) goto nomem;
178 pfSetMemory( dic, 0, sizeof( cfDictionary ));
180 dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
\r
182 /* Align dictionary segments to preserve alignment of floats across hosts. */
183 #define DIC_ALIGNMENT_SIZE (0x10)
\r
184 #define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)))
\r
186 /* Allocate memory for header. */
189 dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE );
190 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
\r
191 /* Align header base. */
\r
192 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
193 pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize);
194 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
195 dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase;
199 dic->dic_HeaderBase = NULL;
202 /* Allocate memory for code. */
203 dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE );
204 if( !dic->dic_CodeBaseUnaligned ) goto nomem;
\r
205 dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
206 pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize);
208 dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
209 dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES);
213 pfDeleteDictionary( dic );
217 /***************************************************************
218 ** Used by Quit and other routines to restore system.
219 ***************************************************************/
221 void ResetForthTask( void )
223 /* Go back to terminal input. */
224 gCurrentTask->td_InputStream = PF_STDIN;
227 gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
228 gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
229 #ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */
230 gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
233 /* Advance >IN to end of input. */
234 gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
238 /***************************************************************
239 ** Set current task context.
240 ***************************************************************/
242 void pfSetCurrentTask( cfTaskData *cftd )
247 /***************************************************************
249 ***************************************************************/
251 void pfSetQuiet( int32 IfQuiet )
253 gVarQuiet = (cell) IfQuiet;
256 /***************************************************************
257 ** Query message status.
258 ***************************************************************/
260 int32 pfQueryQuiet( void )
265 /***************************************************************
267 ***************************************************************/
269 int32 pfRunForth( void )
272 return gVarReturnCode;
275 /***************************************************************
276 ** Include file based on 'C' name.
277 ***************************************************************/
279 int32 pfIncludeFile( const char *FileName )
287 fid = sdOpenFile( FileName, "r" );
290 ERR("pfIncludeFile could not open ");
296 /* Create a dictionary word named ::::FileName for FILE? */
297 pfCopyMemory( &buffer[0], "::::", 4);
298 len = pfCStringLength(FileName);
299 numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
300 pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
301 CreateDicEntryC( ID_NOOP, buffer, 0 );
303 Result = ffIncludeFile( fid );
305 /* Create a dictionary word named ;;;; for FILE? */
306 CreateDicEntryC( ID_NOOP, ";;;;", 0 );
312 /***************************************************************
313 ** Output 'C' string message.
314 ** This is provided to help avoid the use of printf() and other I/O
315 ** which may not be present on a small embedded system.
316 ***************************************************************/
318 void pfMessage( const char *CString )
320 ioType( CString, pfCStringLength(CString) );
323 /**************************************************************************
324 ** Main entry point fo pForth
326 int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit )
331 ExecToken EntryPoint = 0;
333 #ifdef PF_USER_INIT
\r
334 Result = PF_USER_INIT;
\r
335 if( Result < 0 ) goto error;
\r
340 /* Allocate Task structure. */
341 cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
345 pfSetCurrentTask( cftd );
347 if( !pfQueryQuiet() )
349 MSG( "PForth V"PFORTH_VERSION"\n" );
353 /* Don't use MSG before task set. */
354 if( IfInit ) MSG("Build dictionary from scratch.\n");
358 MSG("DicName = "); MSG(DicName); MSG("\n");
362 MSG("SourceName = "); MSG(SourceName); MSG("\n");
367 #ifdef PF_NO_GLOBAL_INIT
368 if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */
371 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
374 dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
379 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
381 dic = pfLoadDictionary( DicName, &EntryPoint );
383 if( dic == NULL ) goto error;
385 pfExecByName("AUTO.INIT");
387 if( EntryPoint != 0 )
389 pfExecuteToken( EntryPoint );
394 if( SourceName == NULL )
396 Result = pfRunForth();
403 Result = pfIncludeFile( SourceName );
406 #endif /* PF_NO_SHELL */
407 pfExecByName("AUTO.TERM");
408 pfDeleteDictionary( dic );
409 pfDeleteTask( cftd );
412 #ifdef PF_USER_TERM
\r
419 MSG("pfDoForth: Error occured.\n");
420 pfDeleteTask( cftd );