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