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