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