git.gag.com Git - debian/pforth/blob - csrc/pfcompil.c

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