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