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