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