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