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