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