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