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