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