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(uint32)-1))\r
  29 \r
  30 /***************************************************************/\r
  31 /************** Static Prototypes ******************************/\r
  32 /***************************************************************/\r
  33 \r
  34 static void  ffStringColon( const ForthStringPtr FName );\r
  35 static int32 CheckRedefinition( const ForthStringPtr FName );\r
  36 static void  ffUnSmudge( void );\r
  37 static int32 FindAndCompile( const char *theWord );\r
  38 static int32 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 int32 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, uint32 Flags )\r
  58 {\r
  59         cfNameLinks *cfnl;\r
  60 \r
  61         cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr.Byte;\r
  62 \r
  63 /* Set link to previous header, if any. */\r
  64         if( gVarContext )\r
  65         {\r
  66                 WRITE_LONG_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_LONG_DIC( &cfnl->cfnl_ExecToken, XT );\r
  75 \r
  76 /* Advance Header Dictionary Pointer */\r
  77         gCurrentDictionary->dic_HeaderPtr.Byte += sizeof(cfNameLinks);\r
  78 \r
  79 /* Laydown name. */\r
  80         gVarContext = (char *) gCurrentDictionary->dic_HeaderPtr.Byte;\r
  81         pfCopyMemory( gCurrentDictionary->dic_HeaderPtr.Byte, FName, (*FName)+1 );\r
  82         gCurrentDictionary->dic_HeaderPtr.Byte += (*FName)+1;\r
  83 \r
  84 /* Set flags. */\r
  85         *gVarContext |= (char) Flags;\r
  86         \r
  87 /* Align to quad byte boundaries with zeroes. */\r
  88         while( ((uint32) gCurrentDictionary->dic_HeaderPtr.Byte) & UINT32_MASK )\r
  89         {\r
  90                 *gCurrentDictionary->dic_HeaderPtr.Byte++ = 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, uint32 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 RelNamePtr;\r
 111         const cfNameLinks *cfnl;\r
 112 \r
 113 /* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (int32) NFA)); */\r
 114         cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );\r
 115 \r
 116         RelNamePtr = READ_LONG_DIC((const cell *) (&cfnl->cfnl_PreviousName));\r
 117 /* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (int32) 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_LONG_DIC((const cell *) (&cfnl->cfnl_ExecToken));\r
 138 }\r
 139 \r
 140 /***************************************************************\r
 141 ** Find XTs needed by compiler.\r
 142 */\r
 143 int32 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", 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( int32 HeaderSize, int32 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_CFETCH, "C@", 0 );\r
 201         CreateDicEntryC( ID_CMOVE, "CMOVE", 0 );\r
 202         CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 );\r
 203         CreateDicEntryC( ID_COLON, ":", 0 );\r
 204         CreateDicEntryC( ID_COLON_P, "(:)", 0 );\r
 205         CreateDicEntryC( ID_COMPARE, "COMPARE", 0 );\r
 206         CreateDicEntryC( ID_COMP_EQUAL, "=", 0 );\r
 207         CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 );\r
 208         CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 );\r
 209         CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 );\r
 210         pfDebugMessage("pfBuildDictionary: added U>\n");\r
 211         CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 );\r
 212         CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 );\r
 213         CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 );\r
 214         CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 );\r
 215         CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 );\r
 216         CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 );\r
 217         CreateDicEntryC( ID_CR, "CR", 0 );\r
 218         CreateDicEntryC( ID_CREATE, "CREATE", 0 );\r
 219         CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 );\r
 220         CreateDicEntryC( ID_D_PLUS, "D+", 0 );\r
 221         CreateDicEntryC( ID_D_MINUS, "D-", 0 );\r
 222         CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 );\r
 223         CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 );\r
 224         CreateDicEntryC( ID_D_MTIMES, "M*", 0 );\r
 225         pfDebugMessage("pfBuildDictionary: added M*\n");\r
 226         CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 );\r
 227         CreateDicEntryC( ID_DEFER, "DEFER", 0 );\r
 228         CreateDicEntryC( ID_CSTORE, "C!", 0 );\r
 229         CreateDicEntryC( ID_DEPTH, "DEPTH",  0 );\r
 230         pfDebugMessage("pfBuildDictionary: added DEPTH\n");\r
 231         CreateDicEntryC( ID_DIVIDE, "/", 0 );\r
 232         CreateDicEntryC( ID_DOT, ".",  0 );\r
 233         CreateDicEntryC( ID_DOTS, ".S",  0 );\r
 234         pfDebugMessage("pfBuildDictionary: added .S\n");\r
 235         CreateDicEntryC( ID_DO_P, "(DO)", 0 );\r
 236         CreateDicEntryC( ID_DROP, "DROP", 0 );\r
 237         CreateDicEntryC( ID_DUMP, "DUMP", 0 );\r
 238         CreateDicEntryC( ID_DUP, "DUP",  0 );\r
 239         CreateDicEntryC( ID_EMIT_P, "(EMIT)",  0 );\r
 240         pfDebugMessage("pfBuildDictionary: added (EMIT)\n");\r
 241         CreateDeferredC( ID_EMIT_P, "EMIT");\r
 242         pfDebugMessage("pfBuildDictionary: added EMIT\n");\r
 243         CreateDicEntryC( ID_EOL, "EOL",  0 );\r
 244         CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)",  0 );\r
 245         CreateDicEntryC( ID_ERRORQ_P, "?ERROR",  0 );\r
 246         CreateDicEntryC( ID_EXECUTE, "EXECUTE",  0 );\r
 247         CreateDicEntryC( ID_FETCH, "@",  0 );\r
 248         CreateDicEntryC( ID_FILL, "FILL", 0 );\r
 249         CreateDicEntryC( ID_FIND, "FIND",  0 );\r
 250         CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE",  0 );\r
 251         CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE",  0 );\r
 252         CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE",  0 );\r
 253         CreateDicEntryC( ID_FILE_READ, "READ-FILE",  0 );\r
 254         CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE",  0 );\r
 255         CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE",  0 );\r
 256         CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION",  0 );\r
 257         CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE",  0 );\r
 258         CreateDicEntryC( ID_FILE_RO, "R/O",  0 );\r
 259         CreateDicEntryC( ID_FILE_RW, "R/W",  0 );\r
 260         CreateDicEntryC( ID_FILE_WO, "W/O",  0 );\r
 261         CreateDicEntryC( ID_FILE_BIN, "BIN",  0 );\r
 262         CreateDicEntryC( ID_FINDNFA, "FINDNFA",  0 );\r
 263         CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT",  0 );\r
 264         CreateDicEntryC( ID_FREE, "FREE",  0 );\r
 265 #include "pfcompfp.h"\r
 266         CreateDicEntryC( ID_HERE, "HERE",  0 );\r
 267         CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)",  0 );\r
 268         CreateDicEntryC( ID_I, "I",  0 );\r
 269         CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 );\r
 270         CreateDicEntryC( ID_J, "J",  0 );\r
 271         CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE",  0 );\r
 272         CreateDicEntryC( ID_KEY, "KEY",  0 );\r
 273         CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 );\r
 274         CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE );\r
 275         CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 );\r
 276         CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 );\r
 277         CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 );\r
 278         CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 );\r
 279         CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 );\r
 280         CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 );\r
 281         CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 );\r
 282         CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 );\r
 283         CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 );\r
 284         CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 );\r
 285         CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 );\r
 286         CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 );\r
 287         CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 );\r
 288         CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 );\r
 289         CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 );\r
 290         CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 );\r
 291         CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 );\r
 292         CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 );\r
 293         CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 );\r
 294         CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 );\r
 295         CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 );\r
 296         CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 );\r
 297         CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 );\r
 298         CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 );\r
 299         CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 );\r
 300         CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 );\r
 301         CreateDicEntryC( ID_MAX, "MAX", 0 );\r
 302         CreateDicEntryC( ID_MIN, "MIN", 0 );\r
 303         CreateDicEntryC( ID_MINUS, "-", 0 );\r
 304         CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 );\r
 305         CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 );\r
 306         CreateDicEntryC( ID_NOOP, "NOOP", 0 );\r
 307         CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" );\r
 308         CreateDicEntryC( ID_OR, "OR", 0 );\r
 309         CreateDicEntryC( ID_OVER, "OVER", 0 );\r
 310         pfDebugMessage("pfBuildDictionary: added OVER\n");\r
 311         CreateDicEntryC( ID_PICK, "PICK",  0 );\r
 312         CreateDicEntryC( ID_PLUS, "+",  0 );\r
 313         CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 );\r
 314         CreateDicEntryC( ID_PLUS_STORE, "+!",  0 );\r
 315         CreateDicEntryC( ID_QUIT_P, "(QUIT)",  0 );\r
 316         CreateDeferredC( ID_QUIT_P, "QUIT" );\r
 317         CreateDicEntryC( ID_QDO_P, "(?DO)", 0 );\r
 318         CreateDicEntryC( ID_QDUP, "?DUP",  0 );\r
 319         CreateDicEntryC( ID_QTERMINAL, "?TERMINAL",  0 );\r
 320         CreateDicEntryC( ID_QTERMINAL, "KEY?",  0 );\r
 321         CreateDicEntryC( ID_REFILL, "REFILL",  0 );\r
 322         CreateDicEntryC( ID_RESIZE, "RESIZE",  0 );\r
 323         CreateDicEntryC( ID_ROLL, "ROLL",  0 );\r
 324         CreateDicEntryC( ID_ROT, "ROT",  0 );\r
 325         CreateDicEntryC( ID_RSHIFT, "RSHIFT",  0 );\r
 326         CreateDicEntryC( ID_R_DROP, "RDROP",  0 );\r
 327         CreateDicEntryC( ID_R_FETCH, "R@",  0 );\r
 328         CreateDicEntryC( ID_R_FROM, "R>",  0 );\r
 329         CreateDicEntryC( ID_RP_FETCH, "RP@",  0 );\r
 330         CreateDicEntryC( ID_RP_STORE, "RP!",  0 );\r
 331         CreateDicEntryC( ID_SEMICOLON, ";",  FLAG_IMMEDIATE );\r
 332         CreateDicEntryC( ID_SP_FETCH, "SP@",  0 );\r
 333         CreateDicEntryC( ID_SP_STORE, "SP!",  0 );\r
 334         CreateDicEntryC( ID_STORE, "!",  0 );\r
 335         CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)",  0 );\r
 336         CreateDicEntryC( ID_SCAN, "SCAN",  0 );\r
 337         CreateDicEntryC( ID_SKIP, "SKIP",  0 );\r
 338         CreateDicEntryC( ID_SOURCE, "SOURCE",  0 );\r
 339         CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE",  0 );\r
 340         CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID",  0 );\r
 341         CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID",  0 );\r
 342         CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID",  0 );\r
 343         CreateDicEntryC( ID_SWAP, "SWAP",  0 );\r
 344         CreateDicEntryC( ID_TEST1, "TEST1",  0 );\r
 345         CreateDicEntryC( ID_TEST2, "TEST2",  0 );\r
 346         CreateDicEntryC( ID_TICK, "'", 0 );\r
 347         CreateDicEntryC( ID_TIMES, "*", 0 );\r
 348         CreateDicEntryC( ID_THROW, "THROW", 0 );\r
 349         CreateDicEntryC( ID_TO_R, ">R", 0 );\r
 350         CreateDicEntryC( ID_TYPE, "TYPE", 0 );\r
 351         CreateDicEntryC( ID_VAR_BASE, "BASE", 0 );\r
 352         CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 );\r
 353         CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 );\r
 354         CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 );\r
 355         CreateDicEntryC( ID_VAR_DP, "DP", 0 );\r
 356         CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 );\r
 357         CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 );\r
 358         CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 );\r
 359         CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 );\r
 360         CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 );\r
 361         CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 );\r
 362         CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 );\r
 363         CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 );\r
 364         CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 );\r
 365         CreateDicEntryC( ID_VAR_OUT, "OUT", 0 );\r
 366         CreateDicEntryC( ID_VAR_STATE, "STATE", 0 );\r
 367         CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 );\r
 368         CreateDicEntryC( ID_WORD, "WORD", 0 );\r
 369         CreateDicEntryC( ID_WORD_FETCH, "W@", 0 );\r
 370         CreateDicEntryC( ID_WORD_STORE, "W!", 0 );\r
 371         CreateDicEntryC( ID_XOR, "XOR", 0 );\r
 372         CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 );\r
 373         \r
 374         pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");\r
 375         if( FindSpecialXTs() < 0 ) goto error;\r
 376         \r
 377         if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */\r
 378         \r
 379 #ifdef PF_DEBUG\r
 380         DumpMemory( dic->dic_HeaderBase, 256 );\r
 381         DumpMemory( dic->dic_CodeBase, 256 );\r
 382 #endif\r
 383 \r
 384         pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");\r
 385         return (PForthDictionary) dic;\r
 386         \r
 387 error:\r
 388         pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");\r
 389         pfDeleteDictionary( dic );\r
 390         return NULL;\r
 391         \r
 392 nomem:\r
 393         return NULL;\r
 394 }\r
 395 #endif /* !PF_NO_INIT */\r
 396 \r
 397 /*\r
 398 ** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )\r
 399 ** 1 for IMMEDIATE values\r
 400 */\r
 401 cell ffTokenToName( ExecToken XT, const ForthString **NFAPtr )\r
 402 {\r
 403         const ForthString *NameField;\r
 404         int32 Searching = TRUE;\r
 405         cell Result = 0;\r
 406         ExecToken TempXT;\r
 407         \r
 408         NameField = gVarContext;\r
 409 DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext));\r
 410 \r
 411         do\r
 412         {\r
 413                 TempXT = NameToToken( NameField );\r
 414                 \r
 415                 if( TempXT == XT )\r
 416                 {\r
 417 DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField));\r
 418                         *NFAPtr = NameField ;\r
 419                         Result = 1;\r
 420                         Searching = FALSE;\r
 421                 }\r
 422                 else\r
 423                 {\r
 424                         NameField = NameToPrevious( NameField );\r
 425                         if( NameField == NULL )\r
 426                         {\r
 427                                 *NFAPtr = 0;\r
 428                                 Searching = FALSE;\r
 429                         }\r
 430                 }\r
 431         } while ( Searching);\r
 432         \r
 433         return Result;\r
 434 }\r
 435 \r
 436 /*\r
 437 ** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )\r
 438 ** 1 for IMMEDIATE values\r
 439 */\r
 440 cell ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr )\r
 441 {\r
 442         const ForthString *WordChar;\r
 443         uint8 WordLen;\r
 444         const char *NameField, *NameChar;\r
 445         int8 NameLen;\r
 446         int32 Searching = TRUE;\r
 447         cell Result = 0;\r
 448         \r
 449         WordLen = (uint8) ((uint32)*WordName & 0x1F);\r
 450         WordChar = WordName+1;\r
 451         \r
 452         NameField = gVarContext;\r
 453 DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar ));\r
 454 DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext));\r
 455         do\r
 456         {\r
 457                 NameLen = (uint8) ((uint32)(*NameField) & MASK_NAME_SIZE);\r
 458                 NameChar = NameField+1;\r
 459 /* DBUG(("   %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */\r
 460                 if(     ((*NameField & FLAG_SMUDGE) == 0) &&\r
 461                         (NameLen == WordLen) &&\r
 462                         ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */\r
 463                 {\r
 464 DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField));\r
 465                         *NFAPtr = NameField ;\r
 466                         Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1;\r
 467                         Searching = FALSE;\r
 468                 }\r
 469                 else\r
 470                 {\r
 471                         NameField = NameToPrevious( NameField );\r
 472                         if( NameField == NULL )\r
 473                         {\r
 474                                 *NFAPtr = WordName;\r
 475                                 Searching = FALSE;\r
 476                         }\r
 477                 }\r
 478         } while ( Searching);\r
 479 DBUG(("ffFindNFA: returns 0x%x\n", Result));\r
 480         return Result;\r
 481 }\r
 482 \r
 483 \r
 484 /***************************************************************\r
 485 ** ( $name -- $name 0 | xt -1 | xt 1 )\r
 486 ** 1 for IMMEDIATE values\r
 487 */\r
 488 cell ffFind( const ForthString *WordName, ExecToken *pXT )\r
 489 {\r
 490         const ForthString *NFA;\r
 491         int32 Result;\r
 492         \r
 493         Result = ffFindNFA( WordName, &NFA );\r
 494 DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */\r
 495         if( Result )\r
 496         {\r
 497                 *pXT = NameToToken( NFA );\r
 498         }\r
 499         else\r
 500         {\r
 501                 *pXT = (ExecToken) WordName;\r
 502         }\r
 503 \r
 504         return Result;\r
 505 }\r
 506 \r
 507 /****************************************************************\r
 508 ** Find name when passed 'C' string.\r
 509 */\r
 510 cell ffFindC( const char *WordName, ExecToken *pXT )\r
 511 {\r
 512 DBUG(("ffFindC: %s\n", WordName ));\r
 513         CStringToForth( gScratch, WordName );\r
 514         return ffFind( gScratch, pXT );\r
 515 }\r
 516 \r
 517 \r
 518 /***********************************************************/\r
 519 /********* Compiling New Words *****************************/\r
 520 /***********************************************************/\r
 521 #define DIC_SAFETY_MARGIN  (400)\r
 522 \r
 523 /*************************************************************\r
 524 **  Check for dictionary overflow. \r
 525 */\r
 526 static int32 ffCheckDicRoom( void )\r
 527 {\r
 528         int32 RoomLeft;\r
 529         RoomLeft = gCurrentDictionary->dic_HeaderLimit -\r
 530                    gCurrentDictionary->dic_HeaderPtr.Byte;\r
 531         if( RoomLeft < DIC_SAFETY_MARGIN )\r
 532         {\r
 533                 pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM);\r
 534                 return PF_ERR_HEADER_ROOM;\r
 535         }\r
 536 \r
 537         RoomLeft = gCurrentDictionary->dic_CodeLimit -\r
 538                    gCurrentDictionary->dic_CodePtr.Byte;\r
 539         if( RoomLeft < DIC_SAFETY_MARGIN )\r
 540         {\r
 541                 pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM);\r
 542                 return PF_ERR_CODE_ROOM;\r
 543         }\r
 544         return 0;\r
 545 }\r
 546 \r
 547 /*************************************************************\r
 548 **  Create a dictionary entry given a string name. \r
 549 */\r
 550 void ffCreateSecondaryHeader( const ForthStringPtr FName)\r
 551 {\r
 552         pfDebugMessage("ffCreateSecondaryHeader()\n");\r
 553 /* Check for dictionary overflow. */\r
 554         if( ffCheckDicRoom() ) return;\r
 555 \r
 556         pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");\r
 557         CheckRedefinition( FName );\r
 558 /* Align CODE_HERE */\r
 559         CODE_HERE = (cell *)( (((uint32)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK);\r
 560         CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE );\r
 561 DBUG(("ffCreateSecondaryHeader, XT = 0x%x, Name = %8s\n"));\r
 562 }\r
 563 \r
 564 /*************************************************************\r
 565 ** Begin compiling a secondary word.\r
 566 */\r
 567 static void ffStringColon( const ForthStringPtr FName)\r
 568 {\r
 569         ffCreateSecondaryHeader( FName );\r
 570         gVarState = 1;\r
 571 }\r
 572 \r
 573 /*************************************************************\r
 574 ** Read the next ExecToken from the Source and create a word.\r
 575 */\r
 576 void ffColon( void )\r
 577 {\r
 578         char *FName;\r
 579         \r
 580         gDepthAtColon = DATA_STACK_DEPTH;\r
 581         \r
 582         FName = ffWord( BLANK );\r
 583         if( *FName > 0 )\r
 584         {\r
 585                 ffStringColon( FName );\r
 586         }\r
 587 }\r
 588 \r
 589 /*************************************************************\r
 590 ** Check to see if name is already in dictionary.\r
 591 */\r
 592 static int32 CheckRedefinition( const ForthStringPtr FName )\r
 593 {\r
 594         int32 flag;\r
 595         ExecToken XT;\r
 596         \r
 597         flag = ffFind( FName, &XT);\r
 598         if ( flag && !gVarQuiet)\r
 599         {\r
 600                 ioType( FName+1, (int32) *FName );\r
 601                 MSG( " redefined.\n" ); // FIXME - allow user to run off this warning.\r
 602         }\r
 603         return flag;\r
 604 }\r
 605 \r
 606 void ffStringCreate( char *FName)\r
 607 {\r
 608         ffCreateSecondaryHeader( FName );\r
 609         \r
 610         CODE_COMMA( ID_CREATE_P );\r
 611         CODE_COMMA( ID_EXIT );\r
 612         ffFinishSecondary();\r
 613         \r
 614 }\r
 615 \r
 616 /* Read the next ExecToken from the Source and create a word. */\r
 617 void ffCreate( void )\r
 618 {\r
 619         char *FName;\r
 620         \r
 621         FName = ffWord( BLANK );\r
 622         if( *FName > 0 )\r
 623         {\r
 624                 ffStringCreate( FName );\r
 625         }\r
 626 }\r
 627 \r
 628 void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT )\r
 629 {\r
 630         pfDebugMessage("ffStringDefer()\n");\r
 631         ffCreateSecondaryHeader( FName );\r
 632         \r
 633         CODE_COMMA( ID_DEFER_P );\r
 634         CODE_COMMA( DefaultXT );\r
 635         \r
 636         ffFinishSecondary();\r
 637         \r
 638 }\r
 639 #ifndef PF_NO_INIT\r
 640 /* Convert name then create deferred dictionary entry. */\r
 641 static void CreateDeferredC( ExecToken DefaultXT, const char *CName )\r
 642 {\r
 643         char FName[40];\r
 644         CStringToForth( FName, CName );\r
 645         ffStringDefer( FName, DefaultXT );\r
 646 }\r
 647 #endif\r
 648 \r
 649 /* Read the next token from the Source and create a word. */\r
 650 void ffDefer( void )\r
 651 {\r
 652         char *FName;\r
 653         \r
 654         FName = ffWord( BLANK );\r
 655         if( *FName > 0 )\r
 656         {\r
 657                 ffStringDefer( FName, ID_QUIT_P );\r
 658         }\r
 659 }\r
 660 \r
 661 /* Unsmudge the word to make it visible. */\r
 662 void ffUnSmudge( void )\r
 663 {\r
 664         *gVarContext &= ~FLAG_SMUDGE;\r
 665 }\r
 666 \r
 667 /* Implement ; */\r
 668 ThrowCode ffSemiColon( void )\r
 669 {\r
 670         ThrowCode exception = 0;\r
 671         gVarState = 0;\r
 672         \r
 673         if( (gDepthAtColon != DATA_STACK_DEPTH) &&\r
 674             (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */\r
 675         {\r
 676                 exception = THROW_SEMICOLON;\r
 677         }\r
 678         else\r
 679         {\r
 680                 ffFinishSecondary();\r
 681         }\r
 682         gDepthAtColon = DEPTH_AT_COLON_INVALID;\r
 683         return exception;\r
 684 }\r
 685 \r
 686 /* Finish the definition of a Forth word. */\r
 687 void ffFinishSecondary( void )\r
 688 {\r
 689         CODE_COMMA( ID_EXIT );\r
 690         ffUnSmudge();\r
 691 }\r
 692 \r
 693 /**************************************************************/\r
 694 /* Used to pull a number from the dictionary to the stack */\r
 695 void ff2Literal( cell dHi, cell dLo )\r
 696 {\r
 697         CODE_COMMA( ID_2LITERAL_P );\r
 698         CODE_COMMA( dHi );\r
 699         CODE_COMMA( dLo );\r
 700 }\r
 701 void ffALiteral( cell Num )\r
 702 {\r
 703         CODE_COMMA( ID_ALITERAL_P );\r
 704         CODE_COMMA( Num );\r
 705 }\r
 706 void ffLiteral( cell Num )\r
 707 {\r
 708         CODE_COMMA( ID_LITERAL_P );\r
 709         CODE_COMMA( Num );\r
 710 }\r
 711 \r
 712 #ifdef PF_SUPPORT_FP\r
 713 void ffFPLiteral( PF_FLOAT fnum )\r
 714 {\r
 715         /* Hack for Metrowerks complier which won't compile the \r
 716          * original expression. \r
 717          */\r
 718         PF_FLOAT  *temp;\r
 719         cell      *dicPtr;\r
 720 \r
 721 /* Make sure that literal float data is float aligned. */\r
 722         dicPtr = CODE_HERE + 1;\r
 723         while( (((uint32) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0)\r
 724         {\r
 725                 DBUG((" comma NOOP to align FPLiteral\n"));\r
 726                 CODE_COMMA( ID_NOOP );\r
 727         }\r
 728         CODE_COMMA( ID_FP_FLITERAL_P );\r
 729 \r
 730         temp = (PF_FLOAT *)CODE_HERE;\r
 731         WRITE_FLOAT_DIC(temp,fnum);   /* Write to dictionary. */\r
 732         temp++;\r
 733         CODE_HERE = (cell *) temp;\r
 734 }\r
 735 #endif /* PF_SUPPORT_FP */\r
 736 \r
 737 /**************************************************************/\r
 738 ThrowCode FindAndCompile( const char *theWord )\r
 739 {\r
 740         int32 Flag;\r
 741         ExecToken XT;\r
 742         cell Num;\r
 743         ThrowCode exception = 0;\r
 744         \r
 745         Flag = ffFind( theWord, &XT);\r
 746 DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag ));\r
 747 \r
 748 /* Is it a normal word ? */\r
 749         if( Flag == -1 )\r
 750         {\r
 751                 if( gVarState )  /* compiling? */\r
 752                 {\r
 753                         CODE_COMMA( XT );\r
 754                 }\r
 755                 else\r
 756                 {\r
 757                         exception = pfCatch( XT );\r
 758                 }\r
 759         }\r
 760         else if ( Flag == 1 ) /* or is it IMMEDIATE ? */\r
 761         {\r
 762 DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord ));\r
 763                 exception = pfCatch( XT );\r
 764         }\r
 765         else /* try to interpret it as a number. */\r
 766         {\r
 767 /* Call deferred NUMBER? */\r
 768                 int32 NumResult;\r
 769                 \r
 770 DBUG(("FindAndCompile: not found, try number?\n" ));\r
 771                 PUSH_DATA_STACK( theWord );   /* Push text of number */\r
 772                 exception = pfCatch( gNumberQ_XT );\r
 773                 if( exception ) goto error;\r
 774                 \r
 775 DBUG(("FindAndCompile: after number?\n" ));\r
 776                 NumResult = POP_DATA_STACK;  /* Success? */\r
 777                 switch( NumResult )\r
 778                 {\r
 779                 case NUM_TYPE_SINGLE:\r
 780                         if( gVarState )  /* compiling? */\r
 781                         {\r
 782                                 Num = POP_DATA_STACK;\r
 783                                 ffLiteral( Num );\r
 784                         }\r
 785                         break;\r
 786                         \r
 787                 case NUM_TYPE_DOUBLE:\r
 788                         if( gVarState )  /* compiling? */\r
 789                         {\r
 790                                 Num = POP_DATA_STACK;  /* get hi portion */\r
 791                                 ff2Literal( Num, POP_DATA_STACK );\r
 792                         }\r
 793                         break;\r
 794 \r
 795 #ifdef PF_SUPPORT_FP\r
 796                 case NUM_TYPE_FLOAT:\r
 797                         if( gVarState )  /* compiling? */\r
 798                         {\r
 799                                 ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ );\r
 800                         }\r
 801                         break;\r
 802 #endif\r
 803 \r
 804                 case NUM_TYPE_BAD:\r
 805                 default:\r
 806                         ioType( theWord+1, *theWord );\r
 807                         MSG( "  ? - unrecognized word!\n" );\r
 808                         exception = THROW_UNDEFINED_WORD;\r
 809                         break;\r
 810                 \r
 811                 }\r
 812         }\r
 813 error:\r
 814         return exception;\r
 815 }\r
 816 \r
 817 /**************************************************************\r
 818 ** Forth outer interpreter.  Parses words from Source.\r
 819 ** Executes them or compiles them based on STATE.\r
 820 */\r
 821 ThrowCode ffInterpret( void )\r
 822 {\r
 823         int32 flag;\r
 824         char *theWord;\r
 825         ThrowCode exception = 0;\r
 826         \r
 827 /* Is there any text left in Source ? */\r
 828         while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) )\r
 829         {\r
 830         \r
 831                 pfDebugMessage("ffInterpret: calling ffWord(()\n");\r
 832                 theWord = ffWord( BLANK );\r
 833                 DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));\r
 834                 \r
 835                 if( *theWord > 0 )\r
 836                 {\r
 837                         flag = 0;\r
 838                         if( gLocalCompiler_XT )\r
 839                         {\r
 840                                 PUSH_DATA_STACK( theWord );   /* Push word. */\r
 841                                 exception = pfCatch( gLocalCompiler_XT );\r
 842                                 if( exception ) goto error;\r
 843                                 flag = POP_DATA_STACK;  /* Compiled local? */\r
 844                         }\r
 845                         if( flag == 0 )\r
 846                         {\r
 847                                 exception = FindAndCompile( theWord );\r
 848                                 if( exception ) goto error;\r
 849                         }\r
 850                 }\r
 851 \r
 852                 DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN,\r
 853                         gCurrentTask->td_SourceNum ) );\r
 854         }\r
 855         DBUG(("ffInterpret: CHECK_ABORT = %d\n", CHECK_ABORT));\r
 856 error:\r
 857         return exception;\r
 858 }\r
 859                 \r
 860 /**************************************************************/\r
 861 ThrowCode ffOK( void )\r
 862 {\r
 863         int32 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         int32 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 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 ffConvertStreamToSourceID( FileStream *Stream )\r
1044 {\r
1045         cell 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) 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 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 readLineFromStream( char *buffer, cell 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 ffRefill( void )\r
1139 {\r
1140         cell Num;\r
1141         cell 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