projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Implement ENVIRONMENT?
[pforth] / csrc / pfcompil.c
CommitLineData
8e9db35f
PB		 1/* @(#) pfcompil.c 98/01/26 1.5 */
2/***************************************************************
3** Compiler for PForth based on 'C'
4**
5** These routines could be left out of an execute only version.
6**
7** Author: Phil Burk
8** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
9**
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.
18**
19****************************************************************
20** 941004 PLB Extracted IO calls from pforth_main.c
21** 950320 RDG Added underflow checking for FP stack
22***************************************************************/
23
24#include "pf_all.h"
25#include "pfcompil.h"
26
27#define ABORT_RETURN_CODE (10)
28#define UINT32_MASK ((sizeof(ucell_t)-1))
29
30/***************************************************************/
31/************** Static Prototypes ******************************/
32/***************************************************************/
33
34static void ffStringColon( const ForthStringPtr FName );
35static cell_t CheckRedefinition( const ForthStringPtr FName );
36static void ffUnSmudge( void );
37static cell_t FindAndCompile( const char *theWord );
38static cell_t ffCheckDicRoom( void );
39
40#ifndef PF_NO_INIT
41 static void CreateDeferredC( ExecToken DefaultXT, const char *CName );
42#endif
43
44cell_t NotCompiled( const char *FunctionName )
45{
46 MSG("Function ");
47 MSG(FunctionName);
48 MSG(" not compiled in this version of PForth.\n");
49 return -1;
50}
51
52#ifndef PF_NO_SHELL
53/***************************************************************
54** Create an entry in the Dictionary for the given ExecutionToken.
55** FName is name in Forth format.
56*/
57void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags )
58{
59 cfNameLinks *cfnl;
60
61 cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr;
62
63/* Set link to previous header, if any. */
64 if( gVarContext )
65 {
66 WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) );
67 }
68 else
69 {
70 cfnl->cfnl_PreviousName = 0;
71 }
72
73/* Put Execution token in header. */
74 WRITE_CELL_DIC( &cfnl->cfnl_ExecToken, XT );
75
76/* Advance Header Dictionary Pointer */
77 gCurrentDictionary->dic_HeaderPtr += sizeof(cfNameLinks);
78
79/* Laydown name. */
80 gVarContext = gCurrentDictionary->dic_HeaderPtr;
81 pfCopyMemory( (uint8_t *) gCurrentDictionary->dic_HeaderPtr, FName, (*FName)+1 );
82 gCurrentDictionary->dic_HeaderPtr += (*FName)+1;
83
84/* Set flags. */
85 *(char*)gVarContext |= (char) Flags;
86
87/* Align to quad byte boundaries with zeroes. */
88 while( gCurrentDictionary->dic_HeaderPtr & UINT32_MASK )
89 {
90 *(char*)(gCurrentDictionary->dic_HeaderPtr++) = 0;
91 }
92}
93
94/***************************************************************
95** Convert name then create dictionary entry.
96*/
97void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags )
98{
99 ForthString FName[40];
100 CStringToForth( FName, CName, sizeof(FName) );
101 CreateDicEntry( XT, FName, Flags );
102}
103
104/***************************************************************
105** Convert absolute namefield address to previous absolute name
106** field address or NULL.
107*/
108const ForthString *NameToPrevious( const ForthString *NFA )
109{
110 cell_t RelNamePtr;
111 const cfNameLinks *cfnl;
112
113/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */
114 cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
115
116 RelNamePtr = READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_PreviousName));
117/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */
118 if( RelNamePtr )
119 {
120 return ( (ForthString *) NAMEREL_TO_ABS( RelNamePtr ) );
121 }
122 else
123 {
124 return NULL;
125 }
126}
127/***************************************************************
128** Convert NFA to ExecToken.
129*/
130ExecToken NameToToken( const ForthString *NFA )
131{
132 const cfNameLinks *cfnl;
133
134/* Convert absolute namefield address to absolute link field address. */
135 cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );
136
137 return READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_ExecToken));
138}
139
140/***************************************************************
141** Find XTs needed by compiler.
142*/
143cell_t FindSpecialXTs( void )
144{
145 if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind;
146 if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind;
147 if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind;
148DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT ));
149 return 0;
150
151nofind:
152 ERR("FindSpecialXTs failed!\n");
153 return -1;
154}
155
156/***************************************************************
157** Build a dictionary from scratch.
158*/
159#ifndef PF_NO_INIT
160PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize )
161{
162 pfDictionary_t *dic;
163
164 dic = pfCreateDictionary( HeaderSize, CodeSize );
165 if( !dic ) goto nomem;
166
167 pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n");
168
169 gCurrentDictionary = dic;
170 gNumPrimitives = NUM_PRIMITIVES;
171
172 CreateDicEntryC( ID_EXIT, "EXIT", 0 );
173 pfDebugMessage("pfBuildDictionary: added EXIT\n");
174 CreateDicEntryC( ID_1MINUS, "1-", 0 );
175 pfDebugMessage("pfBuildDictionary: added 1-\n");
176 CreateDicEntryC( ID_1PLUS, "1+", 0 );
177 CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 );
178 CreateDicEntryC( ID_2_R_FROM, "2R>", 0 );
179 CreateDicEntryC( ID_2_TO_R, "2>R", 0 );
180 CreateDicEntryC( ID_2DUP, "2DUP", 0 );
181 CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE );
182 CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 );
183 CreateDicEntryC( ID_2MINUS, "2-", 0 );
184 CreateDicEntryC( ID_2PLUS, "2+", 0 );
185 CreateDicEntryC( ID_2OVER, "2OVER", 0 );
186 CreateDicEntryC( ID_2SWAP, "2SWAP", 0 );
187 CreateDicEntryC( ID_ACCEPT_P, "(ACCEPT)", 0 );
188 CreateDeferredC( ID_ACCEPT_P, "ACCEPT" );
189 CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE );
190 CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 );
191 CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 );
192 pfDebugMessage("pfBuildDictionary: added ALLOCATE\n");
193 CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 );
194 CreateDicEntryC( ID_AND, "AND", 0 );
195 CreateDicEntryC( ID_BAIL, "BAIL", 0 );
196 CreateDicEntryC( ID_BRANCH, "BRANCH", 0 );
197 CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 );
198 CreateDicEntryC( ID_BYE, "BYE", 0 );
199 CreateDicEntryC( ID_CATCH, "CATCH", 0 );
200 CreateDicEntryC( ID_CELL, "CELL", 0 );
201 CreateDicEntryC( ID_CELLS, "CELLS", 0 );
202 CreateDicEntryC( ID_CFETCH, "C@", 0 );
203 CreateDicEntryC( ID_CMOVE, "CMOVE", 0 );
204 CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 );
205 CreateDicEntryC( ID_COLON, ":", 0 );
206 CreateDicEntryC( ID_COLON_P, "(:)", 0 );
207 CreateDicEntryC( ID_COMPARE, "COMPARE", 0 );
208 CreateDicEntryC( ID_COMP_EQUAL, "=", 0 );
209 CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 );
210 CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 );
211 CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 );
212 pfDebugMessage("pfBuildDictionary: added U>\n");
213 CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 );
214 CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 );
215 CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 );
216 CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 );
217 CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 );
218 CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 );
219 CreateDicEntryC( ID_CR, "CR", 0 );
220 CreateDicEntryC( ID_CREATE, "CREATE", 0 );
221 CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 );
222 CreateDicEntryC( ID_D_PLUS, "D+", 0 );
223 CreateDicEntryC( ID_D_MINUS, "D-", 0 );
224 CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 );
225 CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 );
226 CreateDicEntryC( ID_D_MTIMES, "M*", 0 );
227 pfDebugMessage("pfBuildDictionary: added M*\n");
228 CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 );
229 CreateDicEntryC( ID_DEFER, "DEFER", 0 );
230 CreateDicEntryC( ID_CSTORE, "C!", 0 );
231 CreateDicEntryC( ID_DEPTH, "DEPTH", 0 );
232 pfDebugMessage("pfBuildDictionary: added DEPTH\n");
233 CreateDicEntryC( ID_DIVIDE, "/", 0 );
234 CreateDicEntryC( ID_DOT, ".", 0 );
235 CreateDicEntryC( ID_DOTS, ".S", 0 );
236 pfDebugMessage("pfBuildDictionary: added .S\n");
237 CreateDicEntryC( ID_DO_P, "(DO)", 0 );
238 CreateDicEntryC( ID_DROP, "DROP", 0 );
239 CreateDicEntryC( ID_DUMP, "DUMP", 0 );
240 CreateDicEntryC( ID_DUP, "DUP", 0 );
241 CreateDicEntryC( ID_EMIT_P, "(EMIT)", 0 );
242 pfDebugMessage("pfBuildDictionary: added (EMIT)\n");
243 CreateDeferredC( ID_EMIT_P, "EMIT");
244 pfDebugMessage("pfBuildDictionary: added EMIT\n");
245 CreateDicEntryC( ID_EOL, "EOL", 0 );
246 CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)", 0 );
247 CreateDicEntryC( ID_ERRORQ_P, "?ERROR", 0 );
248 CreateDicEntryC( ID_EXECUTE, "EXECUTE", 0 );
249 CreateDicEntryC( ID_FETCH, "@", 0 );
250 CreateDicEntryC( ID_FILL, "FILL", 0 );
251 CreateDicEntryC( ID_FIND, "FIND", 0 );
252 CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE", 0 );
253 CreateDicEntryC( ID_FILE_DELETE, "DELETE-FILE", 0 );
254 CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE", 0 );
255 CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE", 0 );
256 CreateDicEntryC( ID_FILE_READ, "READ-FILE", 0 );
257 CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE", 0 );
258 CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE", 0 );
259 CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION", 0 );
260 CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE", 0 );
261 CreateDicEntryC( ID_FILE_RO, "R/O", 0 );
262 CreateDicEntryC( ID_FILE_RW, "R/W", 0 );
263 CreateDicEntryC( ID_FILE_WO, "W/O", 0 );
264 CreateDicEntryC( ID_FILE_BIN, "BIN", 0 );
265 CreateDicEntryC( ID_FINDNFA, "FINDNFA", 0 );
266 CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT", 0 );
267 CreateDicEntryC( ID_FREE, "FREE", 0 );
268#include "pfcompfp.h"
269 CreateDicEntryC( ID_HERE, "HERE", 0 );
270 CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)", 0 );
271 CreateDicEntryC( ID_I, "I", 0 );
272 CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );
273 CreateDicEntryC( ID_J, "J", 0 );
274 CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE", 0 );
275 CreateDicEntryC( ID_KEY, "KEY", 0 );
276 CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );
277 CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );
278 CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );
279 CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );
280 CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );
281 CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );
282 CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );
283 CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );
284 CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );
285 CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );
286 CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );
287 CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );
288 CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );
289 CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );
290 CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );
291 CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );
292 CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );
293 CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );
294 CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );
295 CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );
296 CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );
297 CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );
298 CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );
299 CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );
300 CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );
301 CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );
302 CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );
303 CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );
304 CreateDicEntryC( ID_MAX, "MAX", 0 );
305 CreateDicEntryC( ID_MIN, "MIN", 0 );
306 CreateDicEntryC( ID_MINUS, "-", 0 );
307 CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );
308 CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );
309 CreateDicEntryC( ID_NOOP, "NOOP", 0 );
310 CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );
311 CreateDicEntryC( ID_OR, "OR", 0 );
312 CreateDicEntryC( ID_OVER, "OVER", 0 );
313 pfDebugMessage("pfBuildDictionary: added OVER\n");
314 CreateDicEntryC( ID_PICK, "PICK", 0 );
315 CreateDicEntryC( ID_PLUS, "+", 0 );
316 CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );
317 CreateDicEntryC( ID_PLUS_STORE, "+!", 0 );
318 CreateDicEntryC( ID_QUIT_P, "(QUIT)", 0 );
319 CreateDeferredC( ID_QUIT_P, "QUIT" );
320 CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );
321 CreateDicEntryC( ID_QDUP, "?DUP", 0 );
322 CreateDicEntryC( ID_QTERMINAL, "?TERMINAL", 0 );
323 CreateDicEntryC( ID_QTERMINAL, "KEY?", 0 );
324 CreateDicEntryC( ID_REFILL, "REFILL", 0 );
325 CreateDicEntryC( ID_RESIZE, "RESIZE", 0 );
326 CreateDicEntryC( ID_ROLL, "ROLL", 0 );
327 CreateDicEntryC( ID_ROT, "ROT", 0 );
328 CreateDicEntryC( ID_RSHIFT, "RSHIFT", 0 );
329 CreateDicEntryC( ID_R_DROP, "RDROP", 0 );
330 CreateDicEntryC( ID_R_FETCH, "R@", 0 );
331 CreateDicEntryC( ID_R_FROM, "R>", 0 );
332 CreateDicEntryC( ID_RP_FETCH, "RP@", 0 );
333 CreateDicEntryC( ID_RP_STORE, "RP!", 0 );
334 CreateDicEntryC( ID_SEMICOLON, ";", FLAG_IMMEDIATE );
335 CreateDicEntryC( ID_SP_FETCH, "SP@", 0 );
336 CreateDicEntryC( ID_SP_STORE, "SP!", 0 );
337 CreateDicEntryC( ID_STORE, "!", 0 );
338 CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)", 0 );
339 CreateDicEntryC( ID_SCAN, "SCAN", 0 );
340 CreateDicEntryC( ID_SKIP, "SKIP", 0 );
341 CreateDicEntryC( ID_SOURCE, "SOURCE", 0 );
342 CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE", 0 );
343 CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID", 0 );
344 CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID", 0 );
345 CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID", 0 );
346 CreateDicEntryC( ID_SWAP, "SWAP", 0 );
347 CreateDicEntryC( ID_TEST1, "TEST1", 0 );
348 CreateDicEntryC( ID_TEST2, "TEST2", 0 );
349 CreateDicEntryC( ID_TICK, "'", 0 );
350 CreateDicEntryC( ID_TIMES, "*", 0 );
351 CreateDicEntryC( ID_THROW, "THROW", 0 );
352 CreateDicEntryC( ID_TO_R, ">R", 0 );
353 CreateDicEntryC( ID_TYPE, "TYPE", 0 );
354 CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );
355 CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );
356 CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );
357 CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );
358 CreateDicEntryC( ID_VAR_DP, "DP", 0 );
359 CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );
360 CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );
361 CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );
362 CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );
363 CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );
364 CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );
365 CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );
366 CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );
367 CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );
368 CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );
369 CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );
370 CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );
371 CreateDicEntryC( ID_WORD, "WORD", 0 );
372 CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );
373 CreateDicEntryC( ID_WORD_STORE, "W!", 0 );
374 CreateDicEntryC( ID_XOR, "XOR", 0 );
375 CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );
376
377 pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");
378 if( FindSpecialXTs() < 0 ) goto error;
379
380 if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */
381
382#ifdef PF_DEBUG
383 DumpMemory( dic->dic_HeaderBase, 256 );
384 DumpMemory( dic->dic_CodeBase, 256 );
385#endif
386
387 pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");
388 return (PForthDictionary) dic;
389
390error:
391 pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");
392 pfDeleteDictionary( dic );
393 return NULL;
394
395nomem:
396 return NULL;
397}
398#endif /* !PF_NO_INIT */
399
400/*
401** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )
402** 1 for IMMEDIATE values
403*/
404cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr )
405{
406 const ForthString *NameField;
407 cell_t Searching = TRUE;
408 cell_t Result = 0;
409 ExecToken TempXT;
410
411 NameField = (ForthString *) gVarContext;
412DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));
413
414 do
415 {
416 TempXT = NameToToken( NameField );
417
418 if( TempXT == XT )
419 {
420DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));
421 *NFAPtr = NameField ;
422 Result = 1;
423 Searching = FALSE;
424 }
425 else
426 {
427 NameField = NameToPrevious( NameField );
428 if( NameField == NULL )
429 {
430 *NFAPtr = 0;
431 Searching = FALSE;
432 }
433 }
434 } while ( Searching);
435
436 return Result;
437}
438
439/*
440** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )
441** 1 for IMMEDIATE values
442*/
443cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )
444{
445 const ForthString *WordChar;
446 uint8_t WordLen;
447 const char *NameField, *NameChar;
448 int8_t NameLen;
449 cell_t Searching = TRUE;
450 cell_t Result = 0;
451
452 WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F);
453 WordChar = WordName+1;
454
455 NameField = (ForthString *) gVarContext;
456DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));
457DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));
458 do
459 {
460 NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE);
461 NameChar = NameField+1;
462/* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */
463 if( ((*NameField & FLAG_SMUDGE) == 0) &&
464 (NameLen == WordLen) &&
465 ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */
466 {
467DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));
468 *NFAPtr = NameField ;
469 Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;
470 Searching = FALSE;
471 }
472 else
473 {
474 NameField = NameToPrevious( NameField );
475 if( NameField == NULL )
476 {
477 *NFAPtr = WordName;
478 Searching = FALSE;
479 }
480 }
481 } while ( Searching);
482DBUG(("ffFindNFA: returns 0x%x\n", Result));
483 return Result;
484}
485
486
487/***************************************************************
488** ( $name -- $name 0 | xt -1 | xt 1 )
489** 1 for IMMEDIATE values
490*/
491cell_t ffFind( const ForthString *WordName, ExecToken *pXT )
492{
493 const ForthString *NFA;
494 cell_t Result;
495
496 Result = ffFindNFA( WordName, &NFA );
497DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */
498 if( Result )
499 {
500 *pXT = NameToToken( NFA );
501 }
502 else
503 {
504 *pXT = (ExecToken) WordName;
505 }
506
507 return Result;
508}
509
510/****************************************************************
511** Find name when passed 'C' string.
512*/
513cell_t ffFindC( const char *WordName, ExecToken *pXT )
514{
515DBUG(("ffFindC: %s\n", WordName ));
516 CStringToForth( gScratch, WordName, sizeof(gScratch) );
517 return ffFind( gScratch, pXT );
518}
519
520
521/***********************************************************/
522/********* Compiling New Words *****************************/
523/***********************************************************/
524#define DIC_SAFETY_MARGIN (400)
525
526/*************************************************************
527** Check for dictionary overflow.
528*/
529static cell_t ffCheckDicRoom( void )
530{
531 cell_t RoomLeft;
532 RoomLeft = (char *)gCurrentDictionary->dic_HeaderLimit -
533 (char *)gCurrentDictionary->dic_HeaderPtr;
534 if( RoomLeft < DIC_SAFETY_MARGIN )
535 {
536 pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);
537 return PF_ERR_HEADER_ROOM;
538 }
539
540 RoomLeft = (char *)gCurrentDictionary->dic_CodeLimit -
541 (char *)gCurrentDictionary->dic_CodePtr.Byte;
542 if( RoomLeft < DIC_SAFETY_MARGIN )
543 {
544 pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);
545 return PF_ERR_CODE_ROOM;
546 }
547 return 0;
548}
549
550/*************************************************************
551** Create a dictionary entry given a string name.
552*/
553void ffCreateSecondaryHeader( const ForthStringPtr FName)
554{
555 pfDebugMessage("ffCreateSecondaryHeader()\n");
556/* Check for dictionary overflow. */
557 if( ffCheckDicRoom() ) return;
558
559 pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");
560 CheckRedefinition( FName );
561/* Align CODE_HERE */
562 CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);
563 CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );
564}
565
566/*************************************************************
567** Begin compiling a secondary word.
568*/
569static void ffStringColon( const ForthStringPtr FName)
570{
571 ffCreateSecondaryHeader( FName );
572 gVarState = 1;
573}
574
575/*************************************************************
576** Read the next ExecToken from the Source and create a word.
577*/
578void ffColon( void )
579{
580 char *FName;
581
582 gDepthAtColon = DATA_STACK_DEPTH;
583
584 FName = ffWord( BLANK );
585 if( *FName > 0 )
586 {
587 ffStringColon( FName );
588 }
589}
590
591/*************************************************************
592** Check to see if name is already in dictionary.
593*/
594static cell_t CheckRedefinition( const ForthStringPtr FName )
595{
596 cell_t flag;
597 ExecToken XT;
598
599 flag = ffFind( FName, &XT);
600 if ( flag && !gVarQuiet)
601 {
602 ioType( FName+1, (cell_t) *FName );
603 MSG( " redefined.\n" ); /* FIXME - allow user to run off this warning. */
604 }
605 return flag;
606}
607
608void ffStringCreate( char *FName)
609{
610 ffCreateSecondaryHeader( FName );
611
612 CODE_COMMA( ID_CREATE_P );
613 CODE_COMMA( ID_EXIT );
614 ffFinishSecondary();
615
616}
617
618/* Read the next ExecToken from the Source and create a word. */
619void ffCreate( void )
620{
621 char *FName;
622
623 FName = ffWord( BLANK );
624 if( *FName > 0 )
625 {
626 ffStringCreate( FName );
627 }
628}
629
630void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )
631{
632 pfDebugMessage("ffStringDefer()\n");
633 ffCreateSecondaryHeader( FName );
634
635 CODE_COMMA( ID_DEFER_P );
636 CODE_COMMA( DefaultXT );
637
638 ffFinishSecondary();
639
640}
641#ifndef PF_NO_INIT
642/* Convert name then create deferred dictionary entry. */
643static void CreateDeferredC( ExecToken DefaultXT, const char *CName )
644{
645 char FName[40];
646 CStringToForth( FName, CName, sizeof(FName) );
647 ffStringDefer( FName, DefaultXT );
648}
649#endif
650
651/* Read the next token from the Source and create a word. */
652void ffDefer( void )
653{
654 char *FName;
655
656 FName = ffWord( BLANK );
657 if( *FName > 0 )
658 {
659 ffStringDefer( FName, ID_QUIT_P );
660 }
661}
662
663/* Unsmudge the word to make it visible. */
fb2f857a 664static void ffUnSmudge( void )
8e9db35f
PB		 665{
666 *(char*)gVarContext &= ~FLAG_SMUDGE;
667}
668
669/* Implement ; */
670ThrowCode ffSemiColon( void )
671{
672 ThrowCode exception = 0;
673 gVarState = 0;
674
675 if( (gDepthAtColon != DATA_STACK_DEPTH) &&
676 (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */
677 {
678 exception = THROW_SEMICOLON;
679 }
680 else
681 {
682 ffFinishSecondary();
683 }
684 gDepthAtColon = DEPTH_AT_COLON_INVALID;
685 return exception;
686}
687
688/* Finish the definition of a Forth word. */
689void ffFinishSecondary( void )
690{
691 CODE_COMMA( ID_EXIT );
692 ffUnSmudge();
693}
694
695/**************************************************************/
696/* Used to pull a number from the dictionary to the stack */
697void ff2Literal( cell_t dHi, cell_t dLo )
698{
699 CODE_COMMA( ID_2LITERAL_P );
700 CODE_COMMA( dHi );
701 CODE_COMMA( dLo );
702}
703void ffALiteral( cell_t Num )
704{
705 CODE_COMMA( ID_ALITERAL_P );
706 CODE_COMMA( Num );
707}
708void ffLiteral( cell_t Num )
709{
710 CODE_COMMA( ID_LITERAL_P );
711 CODE_COMMA( Num );
712}
713
714#ifdef PF_SUPPORT_FP
715void ffFPLiteral( PF_FLOAT fnum )
716{
717 /* Hack for Metrowerks complier which won't compile the
718 * original expression.
719 */
720 PF_FLOAT *temp;
721 cell_t *dicPtr;
722
723/* Make sure that literal float data is float aligned. */
724 dicPtr = CODE_HERE + 1;
725 while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)
726 {
727 DBUG((" comma NOOP to align FPLiteral\n"));
728 CODE_COMMA( ID_NOOP );
729 }
730 CODE_COMMA( ID_FP_FLITERAL_P );
731
732 temp = (PF_FLOAT *)CODE_HERE;
733 WRITE_FLOAT_DIC(temp,fnum); /* Write to dictionary. */
734 temp++;
735 CODE_HERE = (cell_t *) temp;
736}
737#endif /* PF_SUPPORT_FP */
738
739/**************************************************************/
fb2f857a 740static ThrowCode FindAndCompile( const char *theWord )
8e9db35f
PB		 741{
742 cell_t Flag;
743 ExecToken XT;
744 cell_t Num;
745 ThrowCode exception = 0;
746
747 Flag = ffFind( theWord, &XT);
748DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));
749
750/* Is it a normal word ? */
751 if( Flag == -1 )
752 {
753 if( gVarState ) /* compiling? */
754 {
755 CODE_COMMA( XT );
756 }
757 else
758 {
759 exception = pfCatch( XT );
760 }
761 }
762 else if ( Flag == 1 ) /* or is it IMMEDIATE ? */
763 {
764DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));
765 exception = pfCatch( XT );
766 }
767 else /* try to interpret it as a number. */
768 {
769/* Call deferred NUMBER? */
770 cell_t NumResult;
771
772DBUG(("FindAndCompile: not found, try number?\n" ));
773 PUSH_DATA_STACK( theWord ); /* Push text of number */
774 exception = pfCatch( gNumberQ_XT );
775 if( exception ) goto error;
776
777DBUG(("FindAndCompile: after number?\n" ));
778 NumResult = POP_DATA_STACK; /* Success? */
779 switch( NumResult )
780 {
781 case NUM_TYPE_SINGLE:
782 if( gVarState ) /* compiling? */
783 {
784 Num = POP_DATA_STACK;
785 ffLiteral( Num );
786 }
787 break;
788
789 case NUM_TYPE_DOUBLE:
790 if( gVarState ) /* compiling? */
791 {
792 Num = POP_DATA_STACK; /* get hi portion */
793 ff2Literal( Num, POP_DATA_STACK );
794 }
795 break;
796
797#ifdef PF_SUPPORT_FP
798 case NUM_TYPE_FLOAT:
799 if( gVarState ) /* compiling? */
800 {
801 ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );
802 }
803 break;
804#endif
805
806 case NUM_TYPE_BAD:
807 default:
808 ioType( theWord+1, *theWord );
809 MSG( " ? - unrecognized word!\n" );
810 exception = THROW_UNDEFINED_WORD;
811 break;
812
813 }
814 }
815error:
816 return exception;
817}
818
819/**************************************************************
820** Forth outer interpreter. Parses words from Source.
821** Executes them or compiles them based on STATE.
822*/
823ThrowCode ffInterpret( void )
824{
825 cell_t flag;
826 char *theWord;
827 ThrowCode exception = 0;
828
829/* Is there any text left in Source ? */
830 while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )
831 {
832
833 pfDebugMessage("ffInterpret: calling ffWord(()\n");
f7548536 834 theWord = ffLWord( BLANK );
8e9db35f
PB		 835 DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));
836
837 if( *theWord > 0 )
838 {
839 flag = 0;
840 if( gLocalCompiler_XT )
841 {
842 PUSH_DATA_STACK( theWord ); /* Push word. */
843 exception = pfCatch( gLocalCompiler_XT );
844 if( exception ) goto error;
845 flag = POP_DATA_STACK; /* Compiled local? */
846 }
847 if( flag == 0 )
848 {
849 exception = FindAndCompile( theWord );
850 if( exception ) goto error;
851 }
852 }
853
854 DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,
855 gCurrentTask->td_SourceNum ) );
856 }
857error:
858 return exception;
859}
860
861/**************************************************************/
862ThrowCode ffOK( void )
863{
864 cell_t exception = 0;
865/* Check for stack underflow. %Q what about overflows? */
866 if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 )
867 {
868 exception = THROW_STACK_UNDERFLOW;
869 }
870#ifdef PF_SUPPORT_FP /* Check floating point stack too! */
871 else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0)
872 {
873 exception = THROW_FLOAT_STACK_UNDERFLOW;
874 }
875#endif
876 else if( gCurrentTask->td_InputStream == PF_STDIN)
877 {
878 if( !gVarState ) /* executing? */
879 {
880 if( !gVarQuiet )
881 {
882 MSG( " ok\n" );
883 if(gVarTraceStack) ffDotS();
884 }
885 else
886 {
887 EMIT_CR;
888 }
889 }
890 }
891 return exception;
892}
893
894/***************************************************************
895** Cleanup Include stack by popping and closing files.
896***************************************************************/
897void pfHandleIncludeError( void )
898{
899 FileStream *cur;
900
901 while( (cur = ffPopInputStream()) != PF_STDIN)
902 {
903 DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur ));
904 sdCloseFile(cur);
905 }
906}
907
908/***************************************************************
909** Interpret input in a loop.
910***************************************************************/
911ThrowCode ffOuterInterpreterLoop( void )
912{
913 cell_t exception = 0;
914 do
915 {
916 exception = ffRefill();
917 if(exception <= 0) break;
918
919 exception = ffInterpret();
920 if( exception == 0 )
921 {
922 exception = ffOK();
923 }
924
925 } while( exception == 0 );
926 return exception;
927}
928
929/***************************************************************
930** Include then close a file
931***************************************************************/
932
933ThrowCode ffIncludeFile( FileStream *InputFile )
934{
935 ThrowCode exception;
936
937/* Push file stream. */
938 exception = ffPushInputStream( InputFile );
939 if( exception < 0 ) return exception;
940
941/* Run outer interpreter for stream. */
942 exception = ffOuterInterpreterLoop();
943 if( exception )
944 {
945 int i;
946/* Report line number and nesting level. */
947 MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber);
948 MSG(", level = "); ffDot(gIncludeIndex );
949 EMIT_CR
950
951/* Dump line of error and show offset in line for >IN */
952 for( i=0; i<gCurrentTask->td_SourceNum; i++ )
953 {
954 char c = gCurrentTask->td_SourcePtr[i];
955 if( c == '\t' ) c = ' ';
956 EMIT(c);
957 }
958 EMIT_CR;
959 for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^');
960 EMIT_CR;
961 }
962
963/* Pop file stream. */
964 ffPopInputStream();
965
966/* ANSI spec specifies that this should also close the file. */
967 sdCloseFile(InputFile);
968
969 return exception;
970}
971
972#endif /* !PF_NO_SHELL */
973
974/***************************************************************
975** Save current input stream on stack, use this new one.
976***************************************************************/
977Err ffPushInputStream( FileStream *InputFile )
978{
979 cell_t Result = 0;
980 IncludeFrame *inf;
981
982/* Push current input state onto special include stack. */
983 if( gIncludeIndex < MAX_INCLUDE_DEPTH )
984 {
985 inf = &gIncludeStack[gIncludeIndex++];
986 inf->inf_FileID = gCurrentTask->td_InputStream;
987 inf->inf_IN = gCurrentTask->td_IN;
988 inf->inf_LineNumber = gCurrentTask->td_LineNumber;
989 inf->inf_SourceNum = gCurrentTask->td_SourceNum;
990/* Copy TIB plus any NUL terminator into saved area. */
991 if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
992 {
993 pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 );
994 }
995
996/* Set new current input. */
997 DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile ));
998 gCurrentTask->td_InputStream = InputFile;
999 gCurrentTask->td_LineNumber = 0;
1000 }
1001 else
1002 {
1003 ERR("ffPushInputStream: max depth exceeded.\n");
1004 return -1;
1005 }
1006
1007
1008 return Result;
1009}
1010
1011/***************************************************************
1012** Go back to reading previous stream.
1013** Just return gCurrentTask->td_InputStream upon underflow.
1014***************************************************************/
1015FileStream *ffPopInputStream( void )
1016{
1017 IncludeFrame *inf;
1018 FileStream *Result;
1019
1020DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex));
1021 Result = gCurrentTask->td_InputStream;
1022
1023/* Restore input state. */
1024 if( gIncludeIndex > 0 )
1025 {
1026 inf = &gIncludeStack[--gIncludeIndex];
1027 gCurrentTask->td_InputStream = inf->inf_FileID;
1028 DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream ));
1029 gCurrentTask->td_IN = inf->inf_IN;
1030 gCurrentTask->td_LineNumber = inf->inf_LineNumber;
1031 gCurrentTask->td_SourceNum = inf->inf_SourceNum;
1032/* Copy TIB plus any NUL terminator into saved area. */
1033 if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) )
1034 {
1035 pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 );
1036 }
1037
1038 }
1039DBUG(("ffPopInputStream: return = 0x%x\n", Result ));
1040
1041 return Result;
1042}
1043
1044/***************************************************************
1045** Convert file pointer to value consistent with SOURCE-ID.
1046***************************************************************/
1047cell_t ffConvertStreamToSourceID( FileStream *Stream )
1048{
1049 cell_t Result;
1050 if(Stream == PF_STDIN)
1051 {
1052 Result = 0;
1053 }
1054 else if(Stream == NULL)
1055 {
1056 Result = -1;
1057 }
1058 else
1059 {
1060 Result = (cell_t) Stream;
1061 }
1062 return Result;
1063}
1064
1065/***************************************************************
1066** Convert file pointer to value consistent with SOURCE-ID.
1067***************************************************************/
1068FileStream * ffConvertSourceIDToStream( cell_t id )
1069{
1070 FileStream *stream;
1071
1072 if( id == 0 )
1073 {
1074 stream = PF_STDIN;
1075 }
1076 else if( id == -1 )
1077 {
1078 stream = NULL;
1079 }
1080 else
1081 {
1082 stream = (FileStream *) id;
1083 }
1084 return stream;
1085}
1086
1087/**************************************************************
1088** Receive line from input stream.
1089** Return length, or -1 for EOF.
1090*/
1091#define BACKSPACE (8)
1092static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream )
1093{
1094 int c;
1095 int len;
1096 char *p;
1097 static int lastChar = 0;
1098 int done = 0;
1099
1100DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream ));
1101 p = buffer;
1102 len = 0;
1103 while( (len < maxChars) && !done )
1104 {
1105 c = sdInputChar(stream);
1106 switch(c)
1107 {
1108 case EOF:
1109 DBUG(("EOF\n"));
1110 done = 1;
1111 if( len <= 0 ) len = -1;
1112 break;
1113
1114 case '\n':
1115 DBUGX(("EOL=\\n\n"));
1116 if( lastChar != '\r' ) done = 1;
1117 break;
1118
1119 case '\r':
1120 DBUGX(("EOL=\\r\n"));
1121 done = 1;
1122 break;
1123
1124 default:
1125 *p++ = (char) c;
1126 len++;
1127 break;
1128 }
1129 lastChar = c;
1130 }
1131
1132/* NUL terminate line to simplify printing when debugging. */
1133 if( (len >= 0) && (len < maxChars) ) p[len] = '\0';
1134
1135 return len;
1136}
1137
1138/**************************************************************
1139** ( -- , fill Source from current stream )
1140** Return 1 if successful, 0 for EOF, or a negative error.
1141*/
1142cell_t ffRefill( void )
1143{
1144 cell_t Num;
1145 cell_t Result = 1;
1146
1147/* reset >IN for parser */
1148 gCurrentTask->td_IN = 0;
1149
1150/* get line from current stream */
1151 if( gCurrentTask->td_InputStream == PF_STDIN )
1152 {
1153 /* ACCEPT is deferred so we call it through the dictionary. */
1154 PUSH_DATA_STACK( gCurrentTask->td_SourcePtr );
1155 PUSH_DATA_STACK( TIB_SIZE );
1156 pfCatch( gAcceptP_XT );
1157 Num = POP_DATA_STACK;
1158 if( Num < 0 )
1159 {
1160 Result = Num;
1161 goto error;
1162 }
1163 }
1164 else
1165 {
1166 Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE,
1167 gCurrentTask->td_InputStream );
1168 if( Num == EOF )
1169 {
1170 Result = 0;
1171 Num = 0;
1172 }
1173 }
1174
1175 gCurrentTask->td_SourceNum = Num;
1176 gCurrentTask->td_LineNumber++; /* Bump for include. */
1177
1178/* echo input if requested */
1179 if( gVarEcho && ( Num > 0))
1180 {
1181 ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum );
1182 EMIT_CR;
1183 }
1184
1185error:
1186 return Result;
1187}
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.