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

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