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