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

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