projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
V25 with 64-bit support
[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
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
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
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
1cb310e6 88 while( ((ucell_t) gCurrentDictionary->dic_HeaderPtr.Byte) & UINT32_MASK )\r
bb6b2dcd 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
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
253 CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE", 0 );\r
254 CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE", 0 );\r
255 CreateDicEntryC( ID_FILE_READ, "READ-FILE", 0 );\r
256 CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE", 0 );\r
257 CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE", 0 );\r
258 CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION", 0 );\r
259 CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE", 0 );\r
260 CreateDicEntryC( ID_FILE_RO, "R/O", 0 );\r
261 CreateDicEntryC( ID_FILE_RW, "R/W", 0 );\r
262 CreateDicEntryC( ID_FILE_WO, "W/O", 0 );\r
263 CreateDicEntryC( ID_FILE_BIN, "BIN", 0 );\r
264 CreateDicEntryC( ID_FINDNFA, "FINDNFA", 0 );\r
265 CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT", 0 );\r
266 CreateDicEntryC( ID_FREE, "FREE", 0 );\r
267#include "pfcompfp.h"\r
268 CreateDicEntryC( ID_HERE, "HERE", 0 );\r
269 CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)", 0 );\r
270 CreateDicEntryC( ID_I, "I", 0 );\r
271 CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );\r
272 CreateDicEntryC( ID_J, "J", 0 );\r
273 CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE", 0 );\r
274 CreateDicEntryC( ID_KEY, "KEY", 0 );\r
275 CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );\r
276 CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );\r
277 CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );\r
278 CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );\r
279 CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );\r
280 CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );\r
281 CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );\r
282 CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );\r
283 CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );\r
284 CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );\r
285 CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );\r
286 CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );\r
287 CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );\r
288 CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );\r
289 CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );\r
290 CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );\r
291 CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );\r
292 CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );\r
293 CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );\r
294 CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );\r
295 CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );\r
296 CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );\r
297 CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );\r
298 CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );\r
299 CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );\r
300 CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );\r
301 CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );\r
302 CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );\r
303 CreateDicEntryC( ID_MAX, "MAX", 0 );\r
304 CreateDicEntryC( ID_MIN, "MIN", 0 );\r
305 CreateDicEntryC( ID_MINUS, "-", 0 );\r
306 CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );\r
307 CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );\r
308 CreateDicEntryC( ID_NOOP, "NOOP", 0 );\r
309 CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );\r
310 CreateDicEntryC( ID_OR, "OR", 0 );\r
311 CreateDicEntryC( ID_OVER, "OVER", 0 );\r
312 pfDebugMessage("pfBuildDictionary: added OVER\n");\r
313 CreateDicEntryC( ID_PICK, "PICK", 0 );\r
314 CreateDicEntryC( ID_PLUS, "+", 0 );\r
315 CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );\r
316 CreateDicEntryC( ID_PLUS_STORE, "+!", 0 );\r
317 CreateDicEntryC( ID_QUIT_P, "(QUIT)", 0 );\r
318 CreateDeferredC( ID_QUIT_P, "QUIT" );\r
319 CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );\r
320 CreateDicEntryC( ID_QDUP, "?DUP", 0 );\r
321 CreateDicEntryC( ID_QTERMINAL, "?TERMINAL", 0 );\r
322 CreateDicEntryC( ID_QTERMINAL, "KEY?", 0 );\r
323 CreateDicEntryC( ID_REFILL, "REFILL", 0 );\r
324 CreateDicEntryC( ID_RESIZE, "RESIZE", 0 );\r
325 CreateDicEntryC( ID_ROLL, "ROLL", 0 );\r
326 CreateDicEntryC( ID_ROT, "ROT", 0 );\r
327 CreateDicEntryC( ID_RSHIFT, "RSHIFT", 0 );\r
328 CreateDicEntryC( ID_R_DROP, "RDROP", 0 );\r
329 CreateDicEntryC( ID_R_FETCH, "R@", 0 );\r
330 CreateDicEntryC( ID_R_FROM, "R>", 0 );\r
331 CreateDicEntryC( ID_RP_FETCH, "RP@", 0 );\r
332 CreateDicEntryC( ID_RP_STORE, "RP!", 0 );\r
333 CreateDicEntryC( ID_SEMICOLON, ";", FLAG_IMMEDIATE );\r
334 CreateDicEntryC( ID_SP_FETCH, "SP@", 0 );\r
335 CreateDicEntryC( ID_SP_STORE, "SP!", 0 );\r
336 CreateDicEntryC( ID_STORE, "!", 0 );\r
337 CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)", 0 );\r
338 CreateDicEntryC( ID_SCAN, "SCAN", 0 );\r
339 CreateDicEntryC( ID_SKIP, "SKIP", 0 );\r
340 CreateDicEntryC( ID_SOURCE, "SOURCE", 0 );\r
341 CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE", 0 );\r
342 CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID", 0 );\r
343 CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID", 0 );\r
344 CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID", 0 );\r
345 CreateDicEntryC( ID_SWAP, "SWAP", 0 );\r
346 CreateDicEntryC( ID_TEST1, "TEST1", 0 );\r
347 CreateDicEntryC( ID_TEST2, "TEST2", 0 );\r
348 CreateDicEntryC( ID_TICK, "'", 0 );\r
349 CreateDicEntryC( ID_TIMES, "*", 0 );\r
350 CreateDicEntryC( ID_THROW, "THROW", 0 );\r
351 CreateDicEntryC( ID_TO_R, ">R", 0 );\r
352 CreateDicEntryC( ID_TYPE, "TYPE", 0 );\r
353 CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );\r
354 CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );\r
355 CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );\r
356 CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );\r
357 CreateDicEntryC( ID_VAR_DP, "DP", 0 );\r
358 CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );\r
359 CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );\r
360 CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );\r
361 CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );\r
362 CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );\r
363 CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );\r
364 CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );\r
365 CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );\r
366 CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );\r
367 CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );\r
368 CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );\r
369 CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );\r
370 CreateDicEntryC( ID_WORD, "WORD", 0 );\r
371 CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );\r
372 CreateDicEntryC( ID_WORD_STORE, "W!", 0 );\r
373 CreateDicEntryC( ID_XOR, "XOR", 0 );\r
374 CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );\r
375 \r
376 pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");\r
377 if( FindSpecialXTs() < 0 ) goto error;\r
378 \r
379 if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */\r
380 \r
381#ifdef PF_DEBUG\r
382 DumpMemory( dic->dic_HeaderBase, 256 );\r
383 DumpMemory( dic->dic_CodeBase, 256 );\r
384#endif\r
385\r
386 pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");\r
387 return (PForthDictionary) dic;\r
388 \r
389error:\r
390 pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");\r
391 pfDeleteDictionary( dic );\r
392 return NULL;\r
393 \r
394nomem:\r
395 return NULL;\r
396}\r
397#endif /* !PF_NO_INIT */\r
398\r
399/*\r
400** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )\r
401** 1 for IMMEDIATE values\r
402*/\r
1cb310e6 403cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr )\r
bb6b2dcd 404{\r
405 const ForthString *NameField;\r
1cb310e6 406 cell_t Searching = TRUE;\r
407 cell_t Result = 0;\r
bb6b2dcd 408 ExecToken TempXT;\r
409 \r
410 NameField = gVarContext;\r
411DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));\r
412\r
413 do\r
414 {\r
415 TempXT = NameToToken( NameField );\r
416 \r
417 if( TempXT == XT )\r
418 {\r
419DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));\r
420 *NFAPtr = NameField ;\r
421 Result = 1;\r
422 Searching = FALSE;\r
423 }\r
424 else\r
425 {\r
426 NameField = NameToPrevious( NameField );\r
427 if( NameField == NULL )\r
428 {\r
429 *NFAPtr = 0;\r
430 Searching = FALSE;\r
431 }\r
432 }\r
433 } while ( Searching);\r
434 \r
435 return Result;\r
436}\r
437\r
438/*\r
439** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )\r
440** 1 for IMMEDIATE values\r
441*/\r
1cb310e6 442cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )\r
bb6b2dcd 443{\r
444 const ForthString *WordChar;\r
1cb310e6 445 uint8_t WordLen;\r
bb6b2dcd 446 const char *NameField, *NameChar;\r
1cb310e6 447 int8_t NameLen;\r
448 cell_t Searching = TRUE;\r
449 cell_t Result = 0;\r
bb6b2dcd 450 \r
1cb310e6 451 WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F);\r
bb6b2dcd 452 WordChar = WordName+1;\r
453 \r
454 NameField = gVarContext;\r
455DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));\r
456DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));\r
457 do\r
458 {\r
1cb310e6 459 NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE);\r
bb6b2dcd 460 NameChar = NameField+1;\r
461/* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */\r
462 if( ((*NameField & FLAG_SMUDGE) == 0) &&\r
463 (NameLen == WordLen) &&\r
464 ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */\r
465 {\r
466DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));\r
467 *NFAPtr = NameField ;\r
468 Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;\r
469 Searching = FALSE;\r
470 }\r
471 else\r
472 {\r
473 NameField = NameToPrevious( NameField );\r
474 if( NameField == NULL )\r
475 {\r
476 *NFAPtr = WordName;\r
477 Searching = FALSE;\r
478 }\r
479 }\r
480 } while ( Searching);\r
481DBUG(("ffFindNFA: returns 0x%x\n", Result));\r
482 return Result;\r
483}\r
484\r
485\r
486/***************************************************************\r
487** ( $name -- $name 0 | xt -1 | xt 1 )\r
488** 1 for IMMEDIATE values\r
489*/\r
1cb310e6 490cell_t ffFind( const ForthString *WordName, ExecToken *pXT )\r
bb6b2dcd 491{\r
492 const ForthString *NFA;\r
1cb310e6 493 cell_t Result;\r
bb6b2dcd 494 \r
495 Result = ffFindNFA( WordName, &NFA );\r
496DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */\r
497 if( Result )\r
498 {\r
499 *pXT = NameToToken( NFA );\r
500 }\r
501 else\r
502 {\r
503 *pXT = (ExecToken) WordName;\r
504 }\r
505\r
506 return Result;\r
507}\r
508\r
509/****************************************************************\r
510** Find name when passed 'C' string.\r
511*/\r
1cb310e6 512cell_t ffFindC( const char *WordName, ExecToken *pXT )\r
bb6b2dcd 513{\r
514DBUG(("ffFindC: %s\n", WordName ));\r
515 CStringToForth( gScratch, WordName );\r
516 return ffFind( gScratch, pXT );\r
517}\r
518\r
519\r
520/***********************************************************/\r
521/********* Compiling New Words *****************************/\r
522/***********************************************************/\r
523#define DIC_SAFETY_MARGIN (400)\r
524\r
525/*************************************************************\r
526** Check for dictionary overflow. \r
527*/\r
1cb310e6 528static cell_t ffCheckDicRoom( void )\r
bb6b2dcd 529{\r
1cb310e6 530 cell_t RoomLeft;\r
bb6b2dcd 531 RoomLeft = gCurrentDictionary->dic_HeaderLimit -\r
532 gCurrentDictionary->dic_HeaderPtr.Byte;\r
533 if( RoomLeft < DIC_SAFETY_MARGIN )\r
534 {\r
535 pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);\r
536 return PF_ERR_HEADER_ROOM;\r
537 }\r
538\r
539 RoomLeft = gCurrentDictionary->dic_CodeLimit -\r
540 gCurrentDictionary->dic_CodePtr.Byte;\r
541 if( RoomLeft < DIC_SAFETY_MARGIN )\r
542 {\r
543 pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);\r
544 return PF_ERR_CODE_ROOM;\r
545 }\r
546 return 0;\r
547}\r
548\r
549/*************************************************************\r
550** Create a dictionary entry given a string name. \r
551*/\r
552void ffCreateSecondaryHeader( const ForthStringPtr FName)\r
553{\r
554 pfDebugMessage("ffCreateSecondaryHeader()\n");\r
555/* Check for dictionary overflow. */\r
556 if( ffCheckDicRoom() ) return;\r
557\r
558 pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");\r
559 CheckRedefinition( FName );\r
560/* Align CODE_HERE */\r
1cb310e6 561 CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);\r
bb6b2dcd 562 CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );\r
bb6b2dcd 563}\r
564\r
565/*************************************************************\r
566** Begin compiling a secondary word.\r
567*/\r
568static void ffStringColon( const ForthStringPtr FName)\r
569{\r
570 ffCreateSecondaryHeader( FName );\r
571 gVarState = 1;\r
572}\r
573\r
574/*************************************************************\r
575** Read the next ExecToken from the Source and create a word.\r
576*/\r
577void ffColon( void )\r
578{\r
579 char *FName;\r
580 \r
581 gDepthAtColon = DATA_STACK_DEPTH;\r
582 \r
583 FName = ffWord( BLANK );\r
584 if( *FName > 0 )\r
585 {\r
586 ffStringColon( FName );\r
587 }\r
588}\r
589\r
590/*************************************************************\r
591** Check to see if name is already in dictionary.\r
592*/\r
1cb310e6 593static cell_t CheckRedefinition( const ForthStringPtr FName )\r
bb6b2dcd 594{\r
1cb310e6 595 cell_t flag;\r
bb6b2dcd 596 ExecToken XT;\r
597 \r
598 flag = ffFind( FName, &XT);\r
599 if ( flag && !gVarQuiet)\r
600 {\r
1cb310e6 601 ioType( FName+1, (cell_t) *FName );\r
bb6b2dcd 602 MSG( " redefined.\n" ); // FIXME - allow user to run off this warning.\r
603 }\r
604 return flag;\r
605}\r
606\r
607void ffStringCreate( char *FName)\r
608{\r
609 ffCreateSecondaryHeader( FName );\r
610 \r
611 CODE_COMMA( ID_CREATE_P );\r
612 CODE_COMMA( ID_EXIT );\r
613 ffFinishSecondary();\r
614 \r
615}\r
616\r
617/* Read the next ExecToken from the Source and create a word. */\r
618void ffCreate( void )\r
619{\r
620 char *FName;\r
621 \r
622 FName = ffWord( BLANK );\r
623 if( *FName > 0 )\r
624 {\r
625 ffStringCreate( FName );\r
626 }\r
627}\r
628\r
629void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )\r
630{\r
631 pfDebugMessage("ffStringDefer()\n");\r
632 ffCreateSecondaryHeader( FName );\r
633 \r
634 CODE_COMMA( ID_DEFER_P );\r
635 CODE_COMMA( DefaultXT );\r
636 \r
637 ffFinishSecondary();\r
638 \r
639}\r
640#ifndef PF_NO_INIT\r
641/* Convert name then create deferred dictionary entry. */\r
642static void CreateDeferredC( ExecToken DefaultXT, const char *CName )\r
643{\r
644 char FName[40];\r
645 CStringToForth( FName, CName );\r
646 ffStringDefer( FName, DefaultXT );\r
647}\r
648#endif\r
649\r
650/* Read the next token from the Source and create a word. */\r
651void ffDefer( void )\r
652{\r
653 char *FName;\r
654 \r
655 FName = ffWord( BLANK );\r
656 if( *FName > 0 )\r
657 {\r
658 ffStringDefer( FName, ID_QUIT_P );\r
659 }\r
660}\r
661\r
662/* Unsmudge the word to make it visible. */\r
663void ffUnSmudge( void )\r
664{\r
665 *gVarContext &= ~FLAG_SMUDGE;\r
666}\r
667\r
668/* Implement ; */\r
669ThrowCode ffSemiColon( void )\r
670{\r
671 ThrowCode exception = 0;\r
672 gVarState = 0;\r
673 \r
674 if( (gDepthAtColon != DATA_STACK_DEPTH) &&\r
675 (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */\r
676 {\r
677 exception = THROW_SEMICOLON;\r
678 }\r
679 else\r
680 {\r
681 ffFinishSecondary();\r
682 }\r
683 gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
684 return exception;\r
685}\r
686\r
687/* Finish the definition of a Forth word. */\r
688void ffFinishSecondary( void )\r
689{\r
690 CODE_COMMA( ID_EXIT );\r
691 ffUnSmudge();\r
692}\r
693\r
694/**************************************************************/\r
695/* Used to pull a number from the dictionary to the stack */\r
1cb310e6 696void ff2Literal( cell_t dHi, cell_t dLo )\r
bb6b2dcd 697{\r
698 CODE_COMMA( ID_2LITERAL_P );\r
699 CODE_COMMA( dHi );\r
700 CODE_COMMA( dLo );\r
701}\r
1cb310e6 702void ffALiteral( cell_t Num )\r
bb6b2dcd 703{\r
704 CODE_COMMA( ID_ALITERAL_P );\r
705 CODE_COMMA( Num );\r
706}\r
1cb310e6 707void ffLiteral( cell_t Num )\r
bb6b2dcd 708{\r
709 CODE_COMMA( ID_LITERAL_P );\r
710 CODE_COMMA( Num );\r
711}\r
712\r
713#ifdef PF_SUPPORT_FP\r
714void ffFPLiteral( PF_FLOAT fnum )\r
715{\r
716 /* Hack for Metrowerks complier which won't compile the \r
717 * original expression. \r
718 */\r
719 PF_FLOAT *temp;\r
1cb310e6 720 cell_t *dicPtr;\r
bb6b2dcd 721\r
722/* Make sure that literal float data is float aligned. */\r
723 dicPtr = CODE_HERE + 1;\r
1cb310e6 724 while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)\r
bb6b2dcd 725 {\r
726 DBUG((" comma NOOP to align FPLiteral\n"));\r
727 CODE_COMMA( ID_NOOP );\r
728 }\r
729 CODE_COMMA( ID_FP_FLITERAL_P );\r
730\r
731 temp = (PF_FLOAT *)CODE_HERE;\r
732 WRITE_FLOAT_DIC(temp,fnum); /* Write to dictionary. */\r
733 temp++;\r
1cb310e6 734 CODE_HERE = (cell_t *) temp;\r
bb6b2dcd 735}\r
736#endif /* PF_SUPPORT_FP */\r
737\r
738/**************************************************************/\r
739ThrowCode FindAndCompile( const char *theWord )\r
740{\r
1cb310e6 741 cell_t Flag;\r
bb6b2dcd 742 ExecToken XT;\r
1cb310e6 743 cell_t Num;\r
bb6b2dcd 744 ThrowCode exception = 0;\r
745 \r
746 Flag = ffFind( theWord, &XT);\r
747DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));\r
748\r
749/* Is it a normal word ? */\r
750 if( Flag == -1 )\r
751 {\r
752 if( gVarState ) /* compiling? */\r
753 {\r
754 CODE_COMMA( XT );\r
755 }\r
756 else\r
757 {\r
758 exception = pfCatch( XT );\r
759 }\r
760 }\r
761 else if ( Flag == 1 ) /* or is it IMMEDIATE ? */\r
762 {\r
763DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));\r
764 exception = pfCatch( XT );\r
765 }\r
766 else /* try to interpret it as a number. */\r
767 {\r
768/* Call deferred NUMBER? */\r
1cb310e6 769 cell_t NumResult;\r
bb6b2dcd 770 \r
771DBUG(("FindAndCompile: not found, try number?\n" ));\r
772 PUSH_DATA_STACK( theWord ); /* Push text of number */\r
773 exception = pfCatch( gNumberQ_XT );\r
774 if( exception ) goto error;\r
775 \r
776DBUG(("FindAndCompile: after number?\n" ));\r
777 NumResult = POP_DATA_STACK; /* Success? */\r
778 switch( NumResult )\r
779 {\r
780 case NUM_TYPE_SINGLE:\r
781 if( gVarState ) /* compiling? */\r
782 {\r
783 Num = POP_DATA_STACK;\r
784 ffLiteral( Num );\r
785 }\r
786 break;\r
787 \r
788 case NUM_TYPE_DOUBLE:\r
789 if( gVarState ) /* compiling? */\r
790 {\r
791 Num = POP_DATA_STACK; /* get hi portion */\r
792 ff2Literal( Num, POP_DATA_STACK );\r
793 }\r
794 break;\r
795\r
796#ifdef PF_SUPPORT_FP\r
797 case NUM_TYPE_FLOAT:\r
798 if( gVarState ) /* compiling? */\r
799 {\r
800 ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );\r
801 }\r
802 break;\r
803#endif\r
804\r
805 case NUM_TYPE_BAD:\r
806 default:\r
807 ioType( theWord+1, *theWord );\r
808 MSG( " ? - unrecognized word!\n" );\r
809 exception = THROW_UNDEFINED_WORD;\r
810 break;\r
811 \r
812 }\r
813 }\r
814error:\r
815 return exception;\r
816}\r
817\r
818/**************************************************************\r
819** Forth outer interpreter. Parses words from Source.\r
820** Executes them or compiles them based on STATE.\r
821*/\r
822ThrowCode ffInterpret( void )\r
823{\r
1cb310e6 824 cell_t flag;\r
bb6b2dcd 825 char *theWord;\r
826 ThrowCode exception = 0;\r
827 \r
828/* Is there any text left in Source ? */\r
829 while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )\r
830 {\r
831 \r
832 pfDebugMessage("ffInterpret: calling ffWord(()\n");\r
833 theWord = ffWord( BLANK );\r
834 DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));\r
835 \r
836 if( *theWord > 0 )\r
837 {\r
838 flag = 0;\r
839 if( gLocalCompiler_XT )\r
840 {\r
841 PUSH_DATA_STACK( theWord ); /* Push word. */\r
842 exception = pfCatch( gLocalCompiler_XT );\r
843 if( exception ) goto error;\r
844 flag = POP_DATA_STACK; /* Compiled local? */\r
845 }\r
846 if( flag == 0 )\r
847 {\r
848 exception = FindAndCompile( theWord );\r
849 if( exception ) goto error;\r
850 }\r
851 }\r
852\r
853 DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,\r
854 gCurrentTask->td_SourceNum ) );\r
855 }\r
bb6b2dcd 856error:\r
857 return exception;\r
858}\r
859 \r
860/**************************************************************/\r
861ThrowCode ffOK( void )\r
862{\r
1cb310e6 863 cell_t exception = 0;\r
bb6b2dcd 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
896void 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
910ThrowCode ffOuterInterpreterLoop( void )\r
911{\r
1cb310e6 912 cell_t exception = 0;\r
bb6b2dcd 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
932ThrowCode 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
973Err ffPushInputStream( FileStream *InputFile )\r
974{\r
1cb310e6 975 cell_t Result = 0;\r
bb6b2dcd 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
1011FileStream *ffPopInputStream( void )\r
1012{\r
1013 IncludeFrame *inf;\r
1014 FileStream *Result;\r
1015 \r
1016DBUG(("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
1035DBUG(("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
1cb310e6 1043cell_t ffConvertStreamToSourceID( FileStream *Stream )\r
bb6b2dcd 1044{\r
1cb310e6 1045 cell_t Result;\r
bb6b2dcd 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
1cb310e6 1056 Result = (cell_t) Stream;\r
bb6b2dcd 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
1cb310e6 1064FileStream * ffConvertSourceIDToStream( cell_t id )\r
bb6b2dcd 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
1cb310e6 1088static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream )\r
bb6b2dcd 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
1096DBUGX(("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
1cb310e6 1138cell_t ffRefill( void )\r
bb6b2dcd 1139{\r
1cb310e6 1140 cell_t Num;\r
1141 cell_t Result = 1;\r
bb6b2dcd 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
1181error:\r
1182 return Result;\r
1183}\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.