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