git.gag.com Git - debian/pforth/blob - csrc/pfcompil.c

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