1 /* @(#) pfcompil.c 98/01/26 1.5 */
\r
2 /***************************************************************
\r
3 ** Compiler for PForth based on 'C'
\r
5 ** These routines could be left out of an execute only version.
\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 ** 941004 PLB Extracted IO calls from pforth_main.c
\r
21 ** 950320 RDG Added underflow checking for FP stack
\r
22 ***************************************************************/
\r
25 #include "pfcompil.h"
\r
27 #define ABORT_RETURN_CODE (10)
\r
28 #define UINT32_MASK ((sizeof(ucell_t)-1))
\r
30 /***************************************************************/
\r
31 /************** Static Prototypes ******************************/
\r
32 /***************************************************************/
\r
34 static void ffStringColon( const ForthStringPtr FName );
\r
35 static cell_t CheckRedefinition( const ForthStringPtr FName );
\r
36 static void ffUnSmudge( void );
\r
37 static cell_t FindAndCompile( const char *theWord );
\r
38 static cell_t ffCheckDicRoom( void );
\r
41 static void CreateDeferredC( ExecToken DefaultXT, const char *CName );
\r
44 cell_t NotCompiled( const char *FunctionName )
\r
48 MSG(" not compiled in this version of PForth.\n");
\r
53 /***************************************************************
\r
54 ** Create an entry in the Dictionary for the given ExecutionToken.
\r
55 ** FName is name in Forth format.
\r
57 void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags )
\r
61 cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr.Byte;
\r
63 /* Set link to previous header, if any. */
\r
66 WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) );
\r
70 cfnl->cfnl_PreviousName = 0;
\r
73 /* Put Execution token in header. */
\r
74 WRITE_CELL_DIC( &cfnl->cfnl_ExecToken, XT );
\r
76 /* Advance Header Dictionary Pointer */
\r
77 gCurrentDictionary->dic_HeaderPtr.Byte += sizeof(cfNameLinks);
\r
80 gVarContext = (char *) gCurrentDictionary->dic_HeaderPtr.Byte;
\r
81 pfCopyMemory( gCurrentDictionary->dic_HeaderPtr.Byte, FName, (*FName)+1 );
\r
82 gCurrentDictionary->dic_HeaderPtr.Byte += (*FName)+1;
\r
85 *gVarContext |= (char) Flags;
\r
87 /* Align to quad byte boundaries with zeroes. */
\r
88 while( ((ucell_t) gCurrentDictionary->dic_HeaderPtr.Byte) & UINT32_MASK )
\r
90 *gCurrentDictionary->dic_HeaderPtr.Byte++ = 0;
\r
94 /***************************************************************
\r
95 ** Convert name then create dictionary entry.
\r
97 void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags )
\r
99 ForthString FName[40];
\r
100 CStringToForth( FName, CName );
\r
101 CreateDicEntry( XT, FName, Flags );
\r
104 /***************************************************************
\r
105 ** Convert absolute namefield address to previous absolute name
\r
106 ** field address or NULL.
\r
108 const ForthString *NameToPrevious( const ForthString *NFA )
\r
111 const cfNameLinks *cfnl;
\r
113 /* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */
\r
114 cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
\r
116 RelNamePtr = READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_PreviousName));
\r
117 /* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */
\r
120 return ( NAMEREL_TO_ABS( RelNamePtr ) );
\r
127 /***************************************************************
\r
128 ** Convert NFA to ExecToken.
\r
130 ExecToken NameToToken( const ForthString *NFA )
\r
132 const cfNameLinks *cfnl;
\r
134 /* Convert absolute namefield address to absolute link field address. */
\r
135 cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
\r
137 return READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_ExecToken));
\r
140 /***************************************************************
\r
141 ** Find XTs needed by compiler.
\r
143 cell_t FindSpecialXTs( void )
\r
145 if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind;
\r
146 if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind;
\r
147 if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind;
\r
148 DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT ));
\r
152 ERR("FindSpecialXTs failed!\n");
\r
156 /***************************************************************
\r
157 ** Build a dictionary from scratch.
\r
160 PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )
\r
162 pfDictionary_t *dic;
\r
164 dic = pfCreateDictionary( HeaderSize, CodeSize );
\r
165 if( !dic ) goto nomem;
\r
167 pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n");
\r
169 gCurrentDictionary = dic;
\r
170 gNumPrimitives = NUM_PRIMITIVES;
\r
172 CreateDicEntryC( ID_EXIT, "EXIT", 0 );
\r
173 pfDebugMessage("pfBuildDictionary: added EXIT\n");
\r
174 CreateDicEntryC( ID_1MINUS, "1-", 0 );
\r
175 pfDebugMessage("pfBuildDictionary: added 1-\n");
\r
176 CreateDicEntryC( ID_1PLUS, "1+", 0 );
\r
177 CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 );
\r
178 CreateDicEntryC( ID_2_R_FROM, "2R>", 0 );
\r
179 CreateDicEntryC( ID_2_TO_R, "2>R", 0 );
\r
180 CreateDicEntryC( ID_2DUP, "2DUP", 0 );
\r
181 CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE );
\r
182 CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 );
\r
183 CreateDicEntryC( ID_2MINUS, "2-", 0 );
\r
184 CreateDicEntryC( ID_2PLUS, "2+", 0 );
\r
185 CreateDicEntryC( ID_2OVER, "2OVER", 0 );
\r
186 CreateDicEntryC( ID_2SWAP, "2SWAP", 0 );
\r
187 CreateDicEntryC( ID_ACCEPT_P, "(ACCEPT)", 0 );
\r
188 CreateDeferredC( ID_ACCEPT_P, "ACCEPT" );
\r
189 CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE );
\r
190 CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 );
\r
191 CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 );
\r
192 pfDebugMessage("pfBuildDictionary: added ALLOCATE\n");
\r
193 CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 );
\r
194 CreateDicEntryC( ID_AND, "AND", 0 );
\r
195 CreateDicEntryC( ID_BAIL, "BAIL", 0 );
\r
196 CreateDicEntryC( ID_BRANCH, "BRANCH", 0 );
\r
197 CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 );
\r
198 CreateDicEntryC( ID_BYE, "BYE", 0 );
\r
199 CreateDicEntryC( ID_CATCH, "CATCH", 0 );
\r
200 CreateDicEntryC( ID_CELL, "CELL", 0 );
\r
201 CreateDicEntryC( ID_CELLS, "CELLS", 0 );
\r
202 CreateDicEntryC( ID_CFETCH, "C@", 0 );
\r
203 CreateDicEntryC( ID_CMOVE, "CMOVE", 0 );
\r
204 CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 );
\r
205 CreateDicEntryC( ID_COLON, ":", 0 );
\r
206 CreateDicEntryC( ID_COLON_P, "(:)", 0 );
\r
207 CreateDicEntryC( ID_COMPARE, "COMPARE", 0 );
\r
208 CreateDicEntryC( ID_COMP_EQUAL, "=", 0 );
\r
209 CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 );
\r
210 CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 );
\r
211 CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 );
\r
212 pfDebugMessage("pfBuildDictionary: added U>\n");
\r
213 CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 );
\r
214 CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 );
\r
215 CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 );
\r
216 CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 );
\r
217 CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 );
\r
218 CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 );
\r
219 CreateDicEntryC( ID_CR, "CR", 0 );
\r
220 CreateDicEntryC( ID_CREATE, "CREATE", 0 );
\r
221 CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 );
\r
222 CreateDicEntryC( ID_D_PLUS, "D+", 0 );
\r
223 CreateDicEntryC( ID_D_MINUS, "D-", 0 );
\r
224 CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 );
\r
225 CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 );
\r
226 CreateDicEntryC( ID_D_MTIMES, "M*", 0 );
\r
227 pfDebugMessage("pfBuildDictionary: added M*\n");
\r
228 CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 );
\r
229 CreateDicEntryC( ID_DEFER, "DEFER", 0 );
\r
230 CreateDicEntryC( ID_CSTORE, "C!", 0 );
\r
231 CreateDicEntryC( ID_DEPTH, "DEPTH", 0 );
\r
232 pfDebugMessage("pfBuildDictionary: added DEPTH\n");
\r
233 CreateDicEntryC( ID_DIVIDE, "/", 0 );
\r
234 CreateDicEntryC( ID_DOT, ".", 0 );
\r
235 CreateDicEntryC( ID_DOTS, ".S", 0 );
\r
236 pfDebugMessage("pfBuildDictionary: added .S\n");
\r
237 CreateDicEntryC( ID_DO_P, "(DO)", 0 );
\r
238 CreateDicEntryC( ID_DROP, "DROP", 0 );
\r
239 CreateDicEntryC( ID_DUMP, "DUMP", 0 );
\r
240 CreateDicEntryC( ID_DUP, "DUP", 0 );
\r
241 CreateDicEntryC( ID_EMIT_P, "(EMIT)", 0 );
\r
242 pfDebugMessage("pfBuildDictionary: added (EMIT)\n");
\r
243 CreateDeferredC( ID_EMIT_P, "EMIT");
\r
244 pfDebugMessage("pfBuildDictionary: added EMIT\n");
\r
245 CreateDicEntryC( ID_EOL, "EOL", 0 );
\r
246 CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)", 0 );
\r
247 CreateDicEntryC( ID_ERRORQ_P, "?ERROR", 0 );
\r
248 CreateDicEntryC( ID_EXECUTE, "EXECUTE", 0 );
\r
249 CreateDicEntryC( ID_FETCH, "@", 0 );
\r
250 CreateDicEntryC( ID_FILL, "FILL", 0 );
\r
251 CreateDicEntryC( ID_FIND, "FIND", 0 );
\r
252 CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE", 0 );
\r
253 CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE", 0 );
\r
254 CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE", 0 );
\r
255 CreateDicEntryC( ID_FILE_READ, "READ-FILE", 0 );
\r
256 CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE", 0 );
\r
257 CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE", 0 );
\r
258 CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION", 0 );
\r
259 CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE", 0 );
\r
260 CreateDicEntryC( ID_FILE_RO, "R/O", 0 );
\r
261 CreateDicEntryC( ID_FILE_RW, "R/W", 0 );
\r
262 CreateDicEntryC( ID_FILE_WO, "W/O", 0 );
\r
263 CreateDicEntryC( ID_FILE_BIN, "BIN", 0 );
\r
264 CreateDicEntryC( ID_FINDNFA, "FINDNFA", 0 );
\r
265 CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT", 0 );
\r
266 CreateDicEntryC( ID_FREE, "FREE", 0 );
\r
267 #include "pfcompfp.h"
\r
268 CreateDicEntryC( ID_HERE, "HERE", 0 );
\r
269 CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)", 0 );
\r
270 CreateDicEntryC( ID_I, "I", 0 );
\r
271 CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );
\r
272 CreateDicEntryC( ID_J, "J", 0 );
\r
273 CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE", 0 );
\r
274 CreateDicEntryC( ID_KEY, "KEY", 0 );
\r
275 CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );
\r
276 CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );
\r
277 CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );
\r
278 CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );
\r
279 CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );
\r
280 CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );
\r
281 CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );
\r
282 CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );
\r
283 CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );
\r
284 CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );
\r
285 CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );
\r
286 CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );
\r
287 CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );
\r
288 CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );
\r
289 CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );
\r
290 CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );
\r
291 CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );
\r
292 CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );
\r
293 CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );
\r
294 CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );
\r
295 CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );
\r
296 CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );
\r
297 CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );
\r
298 CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );
\r
299 CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );
\r
300 CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );
\r
301 CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );
\r
302 CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );
\r
303 CreateDicEntryC( ID_MAX, "MAX", 0 );
\r
304 CreateDicEntryC( ID_MIN, "MIN", 0 );
\r
305 CreateDicEntryC( ID_MINUS, "-", 0 );
\r
306 CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );
\r
307 CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );
\r
308 CreateDicEntryC( ID_NOOP, "NOOP", 0 );
\r
309 CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );
\r
310 CreateDicEntryC( ID_OR, "OR", 0 );
\r
311 CreateDicEntryC( ID_OVER, "OVER", 0 );
\r
312 pfDebugMessage("pfBuildDictionary: added OVER\n");
\r
313 CreateDicEntryC( ID_PICK, "PICK", 0 );
\r
314 CreateDicEntryC( ID_PLUS, "+", 0 );
\r
315 CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );
\r
316 CreateDicEntryC( ID_PLUS_STORE, "+!", 0 );
\r
317 CreateDicEntryC( ID_QUIT_P, "(QUIT)", 0 );
\r
318 CreateDeferredC( ID_QUIT_P, "QUIT" );
\r
319 CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );
\r
320 CreateDicEntryC( ID_QDUP, "?DUP", 0 );
\r
321 CreateDicEntryC( ID_QTERMINAL, "?TERMINAL", 0 );
\r
322 CreateDicEntryC( ID_QTERMINAL, "KEY?", 0 );
\r
323 CreateDicEntryC( ID_REFILL, "REFILL", 0 );
\r
324 CreateDicEntryC( ID_RESIZE, "RESIZE", 0 );
\r
325 CreateDicEntryC( ID_ROLL, "ROLL", 0 );
\r
326 CreateDicEntryC( ID_ROT, "ROT", 0 );
\r
327 CreateDicEntryC( ID_RSHIFT, "RSHIFT", 0 );
\r
328 CreateDicEntryC( ID_R_DROP, "RDROP", 0 );
\r
329 CreateDicEntryC( ID_R_FETCH, "R@", 0 );
\r
330 CreateDicEntryC( ID_R_FROM, "R>", 0 );
\r
331 CreateDicEntryC( ID_RP_FETCH, "RP@", 0 );
\r
332 CreateDicEntryC( ID_RP_STORE, "RP!", 0 );
\r
333 CreateDicEntryC( ID_SEMICOLON, ";", FLAG_IMMEDIATE );
\r
334 CreateDicEntryC( ID_SP_FETCH, "SP@", 0 );
\r
335 CreateDicEntryC( ID_SP_STORE, "SP!", 0 );
\r
336 CreateDicEntryC( ID_STORE, "!", 0 );
\r
337 CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)", 0 );
\r
338 CreateDicEntryC( ID_SCAN, "SCAN", 0 );
\r
339 CreateDicEntryC( ID_SKIP, "SKIP", 0 );
\r
340 CreateDicEntryC( ID_SOURCE, "SOURCE", 0 );
\r
341 CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE", 0 );
\r
342 CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID", 0 );
\r
343 CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID", 0 );
\r
344 CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID", 0 );
\r
345 CreateDicEntryC( ID_SWAP, "SWAP", 0 );
\r
346 CreateDicEntryC( ID_TEST1, "TEST1", 0 );
\r
347 CreateDicEntryC( ID_TEST2, "TEST2", 0 );
\r
348 CreateDicEntryC( ID_TICK, "'", 0 );
\r
349 CreateDicEntryC( ID_TIMES, "*", 0 );
\r
350 CreateDicEntryC( ID_THROW, "THROW", 0 );
\r
351 CreateDicEntryC( ID_TO_R, ">R", 0 );
\r
352 CreateDicEntryC( ID_TYPE, "TYPE", 0 );
\r
353 CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );
\r
354 CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );
\r
355 CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );
\r
356 CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );
\r
357 CreateDicEntryC( ID_VAR_DP, "DP", 0 );
\r
358 CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );
\r
359 CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );
\r
360 CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );
\r
361 CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );
\r
362 CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );
\r
363 CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );
\r
364 CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );
\r
365 CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );
\r
366 CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );
\r
367 CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );
\r
368 CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );
\r
369 CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );
\r
370 CreateDicEntryC( ID_WORD, "WORD", 0 );
\r
371 CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );
\r
372 CreateDicEntryC( ID_WORD_STORE, "W!", 0 );
\r
373 CreateDicEntryC( ID_XOR, "XOR", 0 );
\r
374 CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );
\r
376 pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");
\r
377 if( FindSpecialXTs() < 0 ) goto error;
\r
379 if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */
\r
382 DumpMemory( dic->dic_HeaderBase, 256 );
\r
383 DumpMemory( dic->dic_CodeBase, 256 );
\r
386 pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");
\r
387 return (PForthDictionary) dic;
\r
390 pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");
\r
391 pfDeleteDictionary( dic );
\r
397 #endif /* !PF_NO_INIT */
\r
400 ** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )
\r
401 ** 1 for IMMEDIATE values
\r
403 cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr )
\r
405 const ForthString *NameField;
\r
406 cell_t Searching = TRUE;
\r
410 NameField = gVarContext;
\r
411 DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));
\r
415 TempXT = NameToToken( NameField );
\r
419 DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));
\r
420 *NFAPtr = NameField ;
\r
426 NameField = NameToPrevious( NameField );
\r
427 if( NameField == NULL )
\r
433 } while ( Searching);
\r
439 ** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )
\r
440 ** 1 for IMMEDIATE values
\r
442 cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )
\r
444 const ForthString *WordChar;
\r
446 const char *NameField, *NameChar;
\r
448 cell_t Searching = TRUE;
\r
451 WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F);
\r
452 WordChar = WordName+1;
\r
454 NameField = gVarContext;
\r
455 DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));
\r
456 DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));
\r
459 NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE);
\r
460 NameChar = NameField+1;
\r
461 /* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */
\r
462 if( ((*NameField & FLAG_SMUDGE) == 0) &&
\r
463 (NameLen == WordLen) &&
\r
464 ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */
\r
466 DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));
\r
467 *NFAPtr = NameField ;
\r
468 Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;
\r
473 NameField = NameToPrevious( NameField );
\r
474 if( NameField == NULL )
\r
476 *NFAPtr = WordName;
\r
480 } while ( Searching);
\r
481 DBUG(("ffFindNFA: returns 0x%x\n", Result));
\r
486 /***************************************************************
\r
487 ** ( $name -- $name 0 | xt -1 | xt 1 )
\r
488 ** 1 for IMMEDIATE values
\r
490 cell_t ffFind( const ForthString *WordName, ExecToken *pXT )
\r
492 const ForthString *NFA;
\r
495 Result = ffFindNFA( WordName, &NFA );
\r
496 DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */
\r
499 *pXT = NameToToken( NFA );
\r
503 *pXT = (ExecToken) WordName;
\r
509 /****************************************************************
\r
510 ** Find name when passed 'C' string.
\r
512 cell_t ffFindC( const char *WordName, ExecToken *pXT )
\r
514 DBUG(("ffFindC: %s\n", WordName ));
\r
515 CStringToForth( gScratch, WordName );
\r
516 return ffFind( gScratch, pXT );
\r
520 /***********************************************************/
\r
521 /********* Compiling New Words *****************************/
\r
522 /***********************************************************/
\r
523 #define DIC_SAFETY_MARGIN (400)
\r
525 /*************************************************************
\r
526 ** Check for dictionary overflow.
\r
528 static cell_t ffCheckDicRoom( void )
\r
531 RoomLeft = gCurrentDictionary->dic_HeaderLimit -
\r
532 gCurrentDictionary->dic_HeaderPtr.Byte;
\r
533 if( RoomLeft < DIC_SAFETY_MARGIN )
\r
535 pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);
\r
536 return PF_ERR_HEADER_ROOM;
\r
539 RoomLeft = gCurrentDictionary->dic_CodeLimit -
\r
540 gCurrentDictionary->dic_CodePtr.Byte;
\r
541 if( RoomLeft < DIC_SAFETY_MARGIN )
\r
543 pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);
\r
544 return PF_ERR_CODE_ROOM;
\r
549 /*************************************************************
\r
550 ** Create a dictionary entry given a string name.
\r
552 void ffCreateSecondaryHeader( const ForthStringPtr FName)
\r
554 pfDebugMessage("ffCreateSecondaryHeader()\n");
\r
555 /* Check for dictionary overflow. */
\r
556 if( ffCheckDicRoom() ) return;
\r
558 pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");
\r
559 CheckRedefinition( FName );
\r
560 /* Align CODE_HERE */
\r
561 CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);
\r
562 CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );
\r
565 /*************************************************************
\r
566 ** Begin compiling a secondary word.
\r
568 static void ffStringColon( const ForthStringPtr FName)
\r
570 ffCreateSecondaryHeader( FName );
\r
574 /*************************************************************
\r
575 ** Read the next ExecToken from the Source and create a word.
\r
577 void ffColon( void )
\r
581 gDepthAtColon = DATA_STACK_DEPTH;
\r
583 FName = ffWord( BLANK );
\r
586 ffStringColon( FName );
\r
590 /*************************************************************
\r
591 ** Check to see if name is already in dictionary.
\r
593 static cell_t CheckRedefinition( const ForthStringPtr FName )
\r
598 flag = ffFind( FName, &XT);
\r
599 if ( flag && !gVarQuiet)
\r
601 ioType( FName+1, (cell_t) *FName );
\r
602 MSG( " redefined.\n" ); // FIXME - allow user to run off this warning.
\r
607 void ffStringCreate( char *FName)
\r
609 ffCreateSecondaryHeader( FName );
\r
611 CODE_COMMA( ID_CREATE_P );
\r
612 CODE_COMMA( ID_EXIT );
\r
613 ffFinishSecondary();
\r
617 /* Read the next ExecToken from the Source and create a word. */
\r
618 void ffCreate( void )
\r
622 FName = ffWord( BLANK );
\r
625 ffStringCreate( FName );
\r
629 void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )
\r
631 pfDebugMessage("ffStringDefer()\n");
\r
632 ffCreateSecondaryHeader( FName );
\r
634 CODE_COMMA( ID_DEFER_P );
\r
635 CODE_COMMA( DefaultXT );
\r
637 ffFinishSecondary();
\r
641 /* Convert name then create deferred dictionary entry. */
\r
642 static void CreateDeferredC( ExecToken DefaultXT, const char *CName )
\r
645 CStringToForth( FName, CName );
\r
646 ffStringDefer( FName, DefaultXT );
\r
650 /* Read the next token from the Source and create a word. */
\r
651 void ffDefer( void )
\r
655 FName = ffWord( BLANK );
\r
658 ffStringDefer( FName, ID_QUIT_P );
\r
662 /* Unsmudge the word to make it visible. */
\r
663 void ffUnSmudge( void )
\r
665 *gVarContext &= ~FLAG_SMUDGE;
\r
669 ThrowCode ffSemiColon( void )
\r
671 ThrowCode exception = 0;
\r
674 if( (gDepthAtColon != DATA_STACK_DEPTH) &&
\r
675 (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */
\r
677 exception = THROW_SEMICOLON;
\r
681 ffFinishSecondary();
\r
683 gDepthAtColon = DEPTH_AT_COLON_INVALID;
\r
687 /* Finish the definition of a Forth word. */
\r
688 void ffFinishSecondary( void )
\r
690 CODE_COMMA( ID_EXIT );
\r
694 /**************************************************************/
\r
695 /* Used to pull a number from the dictionary to the stack */
\r
696 void ff2Literal( cell_t dHi, cell_t dLo )
\r
698 CODE_COMMA( ID_2LITERAL_P );
\r
702 void ffALiteral( cell_t Num )
\r
704 CODE_COMMA( ID_ALITERAL_P );
\r
707 void ffLiteral( cell_t Num )
\r
709 CODE_COMMA( ID_LITERAL_P );
\r
713 #ifdef PF_SUPPORT_FP
\r
714 void ffFPLiteral( PF_FLOAT fnum )
\r
716 /* Hack for Metrowerks complier which won't compile the
\r
717 * original expression.
\r
722 /* Make sure that literal float data is float aligned. */
\r
723 dicPtr = CODE_HERE + 1;
\r
724 while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)
\r
726 DBUG((" comma NOOP to align FPLiteral\n"));
\r
727 CODE_COMMA( ID_NOOP );
\r
729 CODE_COMMA( ID_FP_FLITERAL_P );
\r
731 temp = (PF_FLOAT *)CODE_HERE;
\r
732 WRITE_FLOAT_DIC(temp,fnum); /* Write to dictionary. */
\r
734 CODE_HERE = (cell_t *) temp;
\r
736 #endif /* PF_SUPPORT_FP */
\r
738 /**************************************************************/
\r
739 ThrowCode FindAndCompile( const char *theWord )
\r
744 ThrowCode exception = 0;
\r
746 Flag = ffFind( theWord, &XT);
\r
747 DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));
\r
749 /* Is it a normal word ? */
\r
752 if( gVarState ) /* compiling? */
\r
758 exception = pfCatch( XT );
\r
761 else if ( Flag == 1 ) /* or is it IMMEDIATE ? */
\r
763 DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));
\r
764 exception = pfCatch( XT );
\r
766 else /* try to interpret it as a number. */
\r
768 /* Call deferred NUMBER? */
\r
771 DBUG(("FindAndCompile: not found, try number?\n" ));
\r
772 PUSH_DATA_STACK( theWord ); /* Push text of number */
\r
773 exception = pfCatch( gNumberQ_XT );
\r
774 if( exception ) goto error;
\r
776 DBUG(("FindAndCompile: after number?\n" ));
\r
777 NumResult = POP_DATA_STACK; /* Success? */
\r
778 switch( NumResult )
\r
780 case NUM_TYPE_SINGLE:
\r
781 if( gVarState ) /* compiling? */
\r
783 Num = POP_DATA_STACK;
\r
788 case NUM_TYPE_DOUBLE:
\r
789 if( gVarState ) /* compiling? */
\r
791 Num = POP_DATA_STACK; /* get hi portion */
\r
792 ff2Literal( Num, POP_DATA_STACK );
\r
796 #ifdef PF_SUPPORT_FP
\r
797 case NUM_TYPE_FLOAT:
\r
798 if( gVarState ) /* compiling? */
\r
800 ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );
\r
807 ioType( theWord+1, *theWord );
\r
808 MSG( " ? - unrecognized word!\n" );
\r
809 exception = THROW_UNDEFINED_WORD;
\r
818 /**************************************************************
\r
819 ** Forth outer interpreter. Parses words from Source.
\r
820 ** Executes them or compiles them based on STATE.
\r
822 ThrowCode ffInterpret( void )
\r
826 ThrowCode exception = 0;
\r
828 /* Is there any text left in Source ? */
\r
829 while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )
\r
832 pfDebugMessage("ffInterpret: calling ffWord(()\n");
\r
833 theWord = ffWord( BLANK );
\r
834 DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));
\r
839 if( gLocalCompiler_XT )
\r
841 PUSH_DATA_STACK( theWord ); /* Push word. */
\r
842 exception = pfCatch( gLocalCompiler_XT );
\r
843 if( exception ) goto error;
\r
844 flag = POP_DATA_STACK; /* Compiled local? */
\r
848 exception = FindAndCompile( theWord );
\r
849 if( exception ) goto error;
\r
853 DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,
\r
854 gCurrentTask->td_SourceNum ) );
\r
860 /**************************************************************/
\r
861 ThrowCode ffOK( void )
\r
863 cell_t exception = 0;
\r
864 /* Check for stack underflow. %Q what about overflows? */
\r
865 if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 )
\r
867 exception = THROW_STACK_UNDERFLOW;
\r
869 #ifdef PF_SUPPORT_FP /* Check floating point stack too! */
\r
870 else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0)
\r
872 exception = THROW_FLOAT_STACK_UNDERFLOW;
\r
875 else if( gCurrentTask->td_InputStream == PF_STDIN)
\r
877 if( !gVarState ) /* executing? */
\r
882 if(gVarTraceStack) ffDotS();
\r
893 /***************************************************************
\r
894 ** Cleanup Include stack by popping and closing files.
\r
895 ***************************************************************/
\r
896 void pfHandleIncludeError( void )
\r
900 while( (cur = ffPopInputStream()) != PF_STDIN)
\r
902 DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur ));
\r
907 /***************************************************************
\r
908 ** Interpret input in a loop.
\r
909 ***************************************************************/
\r
910 ThrowCode ffOuterInterpreterLoop( void )
\r
912 cell_t exception = 0;
\r
915 exception = ffRefill();
\r
916 if(exception <= 0) break;
\r
918 exception = ffInterpret();
\r
919 if( exception == 0 )
\r
921 exception = ffOK();
\r
924 } while( exception == 0 );
\r
928 /***************************************************************
\r
930 ***************************************************************/
\r
932 ThrowCode ffIncludeFile( FileStream *InputFile )
\r
934 ThrowCode exception;
\r
936 /* Push file stream. */
\r
937 exception = ffPushInputStream( InputFile );
\r
938 if( exception < 0 ) return exception;
\r
940 /* Run outer interpreter for stream. */
\r
941 exception = ffOuterInterpreterLoop();
\r
945 /* Report line number and nesting level. */
\r
946 MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber);
\r
947 MSG(", level = "); ffDot(gIncludeIndex );
\r
950 /* Dump line of error and show offset in line for >IN */
\r
951 for( i=0; i<gCurrentTask->td_SourceNum; i++ )
\r
953 char c = gCurrentTask->td_SourcePtr[i];
\r
954 if( c == '\t' ) c = ' ';
\r
958 for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^');
\r
962 /* Pop file stream. */
\r
963 ffPopInputStream();
\r
968 #endif /* !PF_NO_SHELL */
\r
970 /***************************************************************
\r
971 ** Save current input stream on stack, use this new one.
\r
972 ***************************************************************/
\r
973 Err ffPushInputStream( FileStream *InputFile )
\r
978 /* Push current input state onto special include stack. */
\r
979 if( gIncludeIndex < MAX_INCLUDE_DEPTH )
\r
981 inf = &gIncludeStack[gIncludeIndex++];
\r
982 inf->inf_FileID = gCurrentTask->td_InputStream;
\r
983 inf->inf_IN = gCurrentTask->td_IN;
\r
984 inf->inf_LineNumber = gCurrentTask->td_LineNumber;
\r
985 inf->inf_SourceNum = gCurrentTask->td_SourceNum;
\r
986 /* Copy TIB plus any NUL terminator into saved area. */
\r
987 if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
\r
989 pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 );
\r
992 /* Set new current input. */
\r
993 DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile ));
\r
994 gCurrentTask->td_InputStream = InputFile;
\r
995 gCurrentTask->td_LineNumber = 0;
\r
999 ERR("ffPushInputStream: max depth exceeded.\n");
\r
1007 /***************************************************************
\r
1008 ** Go back to reading previous stream.
\r
1009 ** Just return gCurrentTask->td_InputStream upon underflow.
\r
1010 ***************************************************************/
\r
1011 FileStream *ffPopInputStream( void )
\r
1013 IncludeFrame *inf;
\r
1014 FileStream *Result;
\r
1016 DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex));
\r
1017 Result = gCurrentTask->td_InputStream;
\r
1019 /* Restore input state. */
\r
1020 if( gIncludeIndex > 0 )
\r
1022 inf = &gIncludeStack[--gIncludeIndex];
\r
1023 gCurrentTask->td_InputStream = inf->inf_FileID;
\r
1024 DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream ));
\r
1025 gCurrentTask->td_IN = inf->inf_IN;
\r
1026 gCurrentTask->td_LineNumber = inf->inf_LineNumber;
\r
1027 gCurrentTask->td_SourceNum = inf->inf_SourceNum;
\r
1028 /* Copy TIB plus any NUL terminator into saved area. */
\r
1029 if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
\r
1031 pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 );
\r
1035 DBUG(("ffPopInputStream: return = 0x%x\n", Result ));
\r
1040 /***************************************************************
\r
1041 ** Convert file pointer to value consistent with SOURCE-ID.
\r
1042 ***************************************************************/
\r
1043 cell_t ffConvertStreamToSourceID( FileStream *Stream )
\r
1046 if(Stream == PF_STDIN)
\r
1050 else if(Stream == NULL)
\r
1056 Result = (cell_t) Stream;
\r
1061 /***************************************************************
\r
1062 ** Convert file pointer to value consistent with SOURCE-ID.
\r
1063 ***************************************************************/
\r
1064 FileStream * ffConvertSourceIDToStream( cell_t id )
\r
1066 FileStream *stream;
\r
1070 stream = PF_STDIN;
\r
1072 else if( id == -1 )
\r
1078 stream = (FileStream *) id;
\r
1083 /**************************************************************
\r
1084 ** Receive line from input stream.
\r
1085 ** Return length, or -1 for EOF.
\r
1087 #define BACKSPACE (8)
\r
1088 static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream )
\r
1093 static int lastChar = 0;
\r
1096 DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream ));
\r
1099 while( (len < maxChars) && !done )
\r
1101 c = sdInputChar(stream);
\r
1107 if( len <= 0 ) len = -1;
\r
1111 DBUGX(("EOL=\\n\n"));
\r
1112 if( lastChar != '\r' ) done = 1;
\r
1116 DBUGX(("EOL=\\r\n"));
\r
1128 /* NUL terminate line to simplify printing when debugging. */
\r
1129 if( (len >= 0) && (len < maxChars) ) p[len] = '\0';
\r
1134 /**************************************************************
\r
1135 ** ( -- , fill Source from current stream )
\r
1136 ** Return 1 if successful, 0 for EOF, or a negative error.
\r
1138 cell_t ffRefill( void )
\r
1141 cell_t Result = 1;
\r
1143 /* reset >IN for parser */
\r
1144 gCurrentTask->td_IN = 0;
\r
1146 /* get line from current stream */
\r
1147 if( gCurrentTask->td_InputStream == PF_STDIN )
\r
1149 /* ACCEPT is deferred so we call it through the dictionary. */
\r
1150 PUSH_DATA_STACK( gCurrentTask->td_SourcePtr );
\r
1151 PUSH_DATA_STACK( TIB_SIZE );
\r
1152 pfCatch( gAcceptP_XT );
\r
1153 Num = POP_DATA_STACK;
\r
1162 Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE,
\r
1163 gCurrentTask->td_InputStream );
\r
1171 gCurrentTask->td_SourceNum = Num;
\r
1172 gCurrentTask->td_LineNumber++; /* Bump for include. */
\r
1174 /* echo input if requested */
\r
1175 if( gVarEcho && ( Num > 0))
\r
1177 ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum );
\r